home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Aminet 31
/
Aminet 31 (1999)(Schatztruhe)[!][Jun 1999].iso
/
Aminet
/
dev
/
basic
/
StatsFuncs.lha
/
StatsFuncs2.asc
Wrap
Text File
|
1999-04-25
|
131KB
|
5,171 lines
;-----------------------------------------------------------------
v$="$VER: StatsFuncs 2.0 (24.4.1999) James L Boyd "
;-----------------------------------------------------------------
.Info
;-----------------------------------------------------------------
; Quick Usage :
; -------------
; IMPORTANT!!! Put Blitzlibs:Amigalibs.res into the "Compiler
; Options" window's Resident box before trying any demos!!!
; 1) Each call has a demonstration underneath it.
; 2) Remember, the function/statement names are case-sensitive.
; --------------
; 3) Also, a lot of these require you to have the resident
; file "blitzlibs:amigalibs.res" present. If you don't know
; what this means : Go to the "Compiler" menu, select
; "Compiler Options...", and type (without the quotes) :
; "blitzlibs:amigalibs.res" in the box underneath the
; "Resident" label. That's it.
; 4) Some of them require a currently used screen, or window.
; 5) I've grouped them according to the context I think they're
; most likely to be used in. You will probably find some that
; you think should be in a different section than they're
; currently in, but we could argue about that all day ;)
; So don't bother telling me :D
;-----------------------------------------------------------------
; Testing the routines :
; ----------------------
; You can test each function or statement by uncommenting the
; function/statement demo you want to try, ONE AT A TIME (you
; MUST re-comment each one before testing another! - unless
; you know what you're doing).
;-----------------------------------------------------------------
; General Information :
; ---------------------
; This set of statements and functions for Blitz Basic 2
; was compiled by James L Boyd, though many of the routines
; were supplied by others.
; Any comments, contributions or bug-fixes to :
; jamesboyd@all-hail.freeserve.co.uk
;-----------------------------------------------------------------
; More information :
; ------------------
; These routines were written for a few reasons :
; 1) They often result in savings on executable file size,
; sometimes quite significantly (not always though ;)
; 2) Some of these routines are not available in any
; Blitz or 3rd party libraries.
; 3) Some of the routines are bugfixed versions of
; existing Blitz/3rd party library routines.
; 4) You don't have to use them as statements or functions,
; but can just strip out the code you need, or just
; use them as a reference for how to do certain things.
; 5) Some of them, of course, are just plain useless :)
;-----------------------------------------------------------------
; Beginners (or "I have no idea what all this is") :
; --------------------------------------------------
; NOTE - none of these example routines exist - I've just
; made 'em up on the spot :)
; Statements - How to call 'em
; ----------------------------
; Statements are commands that don't return
; any values.
; You call a statement just by typing the
; name of the statement and giving any parameters
; it needs :
; eg. HelloText {} might print "Hello" in a window.
; ShowTime {50,50} might put up a requester at
; co-ordinates x=50,y=50 with the time in it.
; Easy :)
; Functions - How to call 'em
; ---------------------------
; Functions are basically commands which return values.
; Some functions perform actions, like opening a requester
; or drawing a graphic in a window :
; eg. result.b=MadeUpRequest {"Hello"} might put up
; a requester with the body text "Hello" and the title
; and gadget text already built into the function. This
; function would probably return the value of the gadget
; that was hit.
; Others just return a value depending on what you've
; supplied them with :
; eg. new$=AddHello {"Mr Bond"}
; This might return "Hello Mr Bond" in new$.
; Functions always return a value, so you must
; have a variable to receive them, even if it's
; just a dummy variable that you do nothing with :
; eg. dummy.l=DoesSomething {"I do nothing"}
; As for what type of variable to use, have a
; look at the function itself - if it says
; Function.b it returns a byte, Function.l
; would return a long, Function$ or Function.s
; would return a string, etc, so you just use that
; type of variable. If it just says Function, it'll
; be a "quick" type (usually the default type).
; You can also use functions in the same way that you
; use any other variable. For example, if a function
; returns a string :
; Request "Test","The time is :"+GetTime {},"OK"
; Because functions act just like variables, you
; can Print any function's result :
; eg. Print ShowSomething {"Hello"} might put
; up a requester which says "Hello" and then when
; you click on the gadget, it prints the result
; into the current window/CLI.
; And if you didn't understand that, just uncomment
; some of the routines (one at a time - re-comment
; each on after testing it!). Try altering the
; values given and see what happens - you'll soon
; get the hang of it :)
;-----------------------------------------------------------------
; DISCLAIMER and stuff :
; ----------------------
; I've added as many credits as possible. If you wrote
; any of these routines (or know who did), let me know!
; Also, I should point out that some have been modified
; to suit the overall format of this file.
; If anyone recognises any of their own routines here,
; let me know, and I'll put the appropriate credit into
; this file (or remove the function if it's a problem) !
; On with the show...
;-----------------------------------------------------------------
.
.Screens
;-----------------------------------------------------------------
; This section deals with routines to do with screen information
; and usage, like finding the screen dimensions and so on.
;-----------------------------------------------------------------
; Current routines :
; NewWBDepth { coloursflag }
; TitleBarHeight { screen }
; ScreenMouseX {}
; ScreenMouseY {}
; IsScreenActive { screen }
; ScreenH { screen }
; ScreenW { screen }
;-----------------------------------------------------------------
; Function NewWBDepth { coloursflag }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; GetBitMapAttr_() fix for gfx cards by Paul Burkey - burkey@bigfoot.com
; Returns depth of user's Workbench screen (or colours
; if you supply a non-zero value (eg. 1!) for coloursflag.
; Like Blitz's WBDepth, but returns correct value on
; graphics card Workbenches too, whereas WBDepth only
; returns a maximum of 8!
; Replaces WBColours {} function from older StatsFuncs...
Function.l NewWBDepth {coloursflag.b}
*sc.Screen=LockPubScreen_ ("Workbench")
If *sc
deep.l=GetBitMapAttr_(*sc\_RastPort\_BitMap,#BMA_DEPTH)
; deep.l=GetBitMapAttr_(*sc\RastPort\BitMap,#BMA_DEPTH)
; NOTE - if you get "offset not found", try uncommenting the
; above line and commenting out the original...different versions
; of amigalibs.res have different offset names...
UnlockPubScreen_ "Workbench",*sc
EndIf
If coloursflag
Function Return 2^deep ; send back colours
Else Function Return deep ; send back depth
EndIf
End Function
; demo :
;NPrint NewWBDepth {0} ; change 0 to -1 (actually, any byte-range value)
; ; to get it to return colours instead of depth
;End
;-----------------------------------------------------------------
; Function : TitleBarHeight { screen }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns the height of the title bar of the specified
; screen, or false if the screen doesn't exist!
; The title-bar height for the screen is ALWAYS the same
; as that of any windows open on the screen, so you can use
; this to get some info before opening a window.
Function.w TitleBarHeight{scr.b}
If Peek.l(Addr Screen(scr))
*scr.Screen=Peek.l(Addr Screen(scr)) ; get screen info...
Function Return *scr\BarHeight+1
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0
; Print TitleBarHeight{0}
; MouseWait:End
;-----------------------------------------------------------------
; Function : ScreenMouseX {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns X position of mouse relative to top-left of
; CURRENTLY USED screen (same as SMouseX, but smaller exec
; size will result).
Function ScreenMouseX {}
*scr.Screen=Peek.l(Addr Screen(Used Screen))
If *scr
Function Return *scr\_MouseX
Else Function Return 0
EndIf
End Function
; demo : see demo for ScreenMouseY{}
;-----------------------------------------------------------------
; Function : ScreenMouseY {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns Y position of mouse relative to top-left of
; CURRENTLY USED screen (same as SMouseY, but smaller exec
; size will result).
Function ScreenMouseY {}
*scr.Screen=Peek.l(Addr Screen(Used Screen))
If *scr
Function Return *scr\_MouseY
Else Function Return 0
EndIf
End Function
; demo :
;; NOTE : Uses ScreenMouseX {} too.
; FindScreen 0
; Window 0,50,50,500,100,$140f,"",1,2
; While Event<>$200
; VWait
; WTitle "X : "+Str$(ScreenMouseX{})+" / Y : "+Str$(ScreenMouseY{})
; Wend
; End
;-----------------------------------------------------------------
; Function : IsScreenActive { screen number }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns True (-1) if screen is active, False (0) if not.
; NOTE : Active DOES NOT necessarily mean the frontmost screen!
Function IsScreenActive {scr.b}
If Peek.l(Addr Screen(scr)) = ActiveScreen
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0
; If IsScreenActive {0}
; Request "","IsScreenActive returned True...","OK"
; Else Request "","IsScreenActive returned False...","OK"
; EndIf
; End
;-----------------------------------------------------------------
; Function : ScreenH { screen number }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Replacement for ScreenHeight, saving around 7k from exec size.
; Returns the height of the specified screen.
; Use ScreenH {Used Screen} if that's convenient to you :)
Function ScreenH {sc.b}
*SC.Screen=Peek.l(Addr Screen(sc))
If *SC
Function Return *SC\Height
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0,"Workbench Screen"
; Request "","Your Workbench screen is "+Str$(ScreenH {0})+" pixels high.","Correct!"
; End
;-----------------------------------------------------------------
; Function : ScreenW { screen number }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Replacement for ScreenWidth, saving around 7k from exec size.
; Returns the width of the specified screen.
; Use ScreenW {Used Screen} if that's convenient to you :)
Function ScreenW {sc.b}
*SC.Screen=Peek.l(Addr Screen(sc))
If *SC
Function Return *SC\Width
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0,"Workbench Screen"
; Request "","Your Workbench screen is "+Str$(ScreenW {0})+" pixels wide.","Correct!"
; End
;-----------------------------------------------------------------
.
.Windows
;-----------------------------------------------------------------
; This section deals with routines to do with window information
; and usage, like finding the window dimensions, drawing in
; windows, fonts in windows, etc.
;-----------------------------------------------------------------
; Current routines :
; FlashText { window, x, y, no , text, speed }
; Draw3dBox { x, y, width, height, style }
; WOutline { x1, y1, x2, y2, hilite, shadow }
; WBevel { x, y, x2, y2, hilite, shadow }
; CenterString { text, window }
; PixelLen { text }
; CentreWindowX { width of window }
; CentreWindowY { height of window }
; WindowOpened { window }
; WindowFillScreen { window number, flags, title }
; WindowW { window }
; WindowH { window }
; WindowFlags { window }
; WinMouseX {}
; WinMouseY {}
; LoadScreenFont { font number }
; WBWinAddr {}
; BFWindow { window, left, top, right, bottom, pen }
; WindowTitle { window, window title, screen title }
; WinCls { colour }
; CleanBorder { window number }
; LockWindow { window }
; UnLockWindow { window, lock }
; HidePointer { window }
; ShowPointer { window }
; WPrint { x, y, text }
; WFBox { window, left, right, top, bottom }
;-----------------------------------------------------------------
; Statement : FlashText { window, x, y, no , text, speed }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; UPDATED by Nick Clover - nick@bauk.freeserve.co.uk
; Now optimised for speed and executable size :)
; Shows flashing text in a window.
; x is the left position, y is the top position, no is the
; number of times to flash, speed is the DELAY in ticks.
; note that this uses colours 1 and 0 - you'll have to
; alter it for anything else...can't add it as parameters
; due to Blitz's 6-parameter limit in statements & functions :(
Statement FlashText {win.b,x.w,y.w,no.w,a$,speed.b}
rp.l=RastPort(0)
strlen=Len(a$)
For a=1 To no*2-1
color=1-color
SetAPen_ rp,color
Move_ rp,x,y
Text_ rp,a$,strlen
Delay_ speed
Next a
SetAPen_ rp,1
Move_ rp,x,y
Text_ rp,a$,strlen
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,640,200,$140f,"FlashText Demo",1,2
; FlashText{0,100,100,5,"Hello,I'm flashing (5 times)!",10}
; End
;-----------------------------------------------------------------
; Statement : Draw3dBox { x, y, width, height, style }
; Draws a 3d box in a window.
; Note that you do need a window to use this!
; See demo for more.
; **** UPDATED by Nick Clover ****
; Optimised for speed and executable size :)
Statement Draw3dBox {ax,ay,Width.l,Height.l,way.b}
ax2.l = ax+Width-1:ay2.l = ay+Height-1
SHARED rp.l
SetAPen_ rp,2-way:Move_ rp,ax2,ay:Draw_ rp,ax,ay:Draw_ rp,ax,ay2
If way=0
SetAPen_ rp,1:Move_ rp,ax+1,ay2 :Draw_ rp,ax2,ay2 :Draw_ rp,ax2,ay
SetAPen_ rp,3:Move_ rp,ax+1,ay2-1:Draw_ rp,ax2-1,ay2-1:Draw_ rp,ax2-1,ay+1
Else
SetAPen_ rp,3:Move_ rp,ax2-1,ay+1:Draw_ rp,ax+1,ay+1:Draw_ rp,ax+1,ay2-1
SetAPen_ rp,2:Move_ rp,ax+1,ay2 :Draw_ rp,ax2,ay2 :Draw_ rp,ax2,ay
EndIf
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,640,200,$140f,"Click to close...",1,2
; rp.l=RastPort(0)
; Draw3dBox{10,10,350,150,0} ; try replacing the 0 with 1 for
; an inverse Box...
; MouseWait:End
;-----------------------------------------------------------------
; Statement : WOutline { x1, y1, x2, y2, hilite, shadow }
; Author : Mark Tiffany
; UPDATED by Nick Clover - nick@bauk.freeserve.co.uk
; Now updated for speed and executable size.
; Draws a nice bounding box in a window...useful for fancy
; borders, gadget boxes, etc.
;IMPORTANT NOTE : You must make the call "rp.l=RastPort (window)"
; before calling this function now - this
; is due to Blitz's 6-parameter limit
; in statements :(
Statement WOutline {x1.w,y1.w,x2.w,y2.w,hilite.w,shadow.w}
SHARED rp.l
SetAPen_ rp,hilite
Move_ rp,x1,y1:Draw_ rp,x2-1,y1:Draw_ rp,x2-1,y2-1:Draw_ rp,x1,y2-1:Draw_ rp,x1,y1
SetAPen_ rp,shadow
Move_ rp,x1+1,y1+1:Draw_ rp,x2,y1+1:Draw_ rp,x2,y2:Draw_ rp,x1+1,y2:Draw_ rp,x1+1,y1+1
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,640,200,$40f,"",1,2
; rp.l=RastPort(0)
;; ^^^ IMPORTANT!!! MUST call this before WOutline!!!
; WOutline{60,60,170,150,1,2} ; try swapping the 1 and 2 over
; for an inverse box :)
; MouseWait:End
;-----------------------------------------------------------------
; Statement : WBevel { x, y, x2, y2, hilite, shadow }
; Author : Mark Tiffany
; UPDATED by Nick Clover - nick@bauk.freeserve.co.uk
; Now updated for speed and executable size.
; Draws a nice bevel box in a window...useful for fancy
; borders, gadget boxes, etc.
;IMPORTANT NOTE : You must make the call "rp.l=RastPort (window)"
; before calling this function now - this
; is due to Blitz's 6-parameter limit
; in statements :(
Statement WBevel{x1.w,y1.w,x2.w,y2.w,hilite.w,shadow.w}
SHARED rp.l
SetAPen_ rp,shadow:Move_ rp,x1,y1:Draw_ rp,x2-1,y1:Draw_ rp,x2-1,y2-1:Draw_ rp,x1,y2-1:Draw_ rp,x1,y1
SetAPen_ rp,hilite:Move_ rp,x1+1,y1+1:Draw_ rp,x2,y1+1:Draw_ rp,x2,y2:Draw_ rp,x1+1,y2:Draw_ rp,x1+1,y1+1
SetAPen_ rp,shadow:Move_ rp,x1+2,y2-2:Draw_ rp,x1+2,y1+2:Draw_ rp,x2-2,y1+2
SetAPen_ rp,hilite:Move_ rp,x2-2,y1+2:Draw_ rp,x2-2,y2-2:Draw_ rp,x1+2,y2-2
SetAPen_ rp,shadow:WritePixel_ rp,x2-1,y1+1:WritePixel_ rp,x1+1,y2-1
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,200,80,$140f,"",1,2
; rp.l=RastPort(0); IMPORTANT!!! MUST call this first now!!!
; WBevel{10,10,100,50,1,2} ; try swapping the 1 and 2 over
; for an inverse bevel :)
; MouseWait:End
;-----------------------------------------------------------------
; Function : CenterString { text, window }
; Returns cursor x position to use for centering a string
; in a given window, using that window's current font
; Returns True (-1) if the string won't fit.
Function.w CenterString{text$,windownum.w}
Use Window (windownum)
*rp.l=RastPort (windownum) ;find the window's rastport
strln.w=Len(text$) ;we need the character count too
pixels.w=TextLength_ (*rp,&text$,strln) ;pixel width of the string
winspace.w=InnerWidth ;available printing width
If pixels<winspace ;there is enough room
startX.w=winspace/2 -pixels/2 ;starting position
Function Return startX ;and send it back
Else ;OH, NO! not enough room!
Function Return -1 ;tell 'em the bad news
EndIf
End Function
; demo
; FindScreen 0
; Window 0,0,0,640,200,$140f,"CenterString test",1,2
; ; *** Try making the window 100 wide ***
; test$="Hello, I'm a very, very long text string. I really am..."
; x.w=CenterString {test$,0}
; ; if x=-1 then the string won't fit :
; If x>-1
; WLocate x,WTopOff:Print test$
; Else Request "","String won't fit!","OK"
; EndIf
; MouseWait:End
;-----------------------------------------------------------------
; Function : PixelLen { text }
; Returns the number of pixels in width required to print
; the requested string.
Function.w PixelLen{a$}
rp.l=RastPort(0) ; The rastport of the used window.
Function Return TextLength_(rp,&a$,Len(a$))
End Function
; demo :
; FindScreen 0
; If Window (0,0,0,640,200,$40f,"",1,2)=0 Then Request "","Window too wide!","END":End
;; if the above function fails on your system, just use :
;; Window 0,0,0,640,200,$40f,"",1,2 ...instead!
; a$="Some Pixels" ; use this text
; pix.w=PixelLen{a$} ; find pixel width of text
;; print information :
; NPrint ""
; NPrint "PixelLen {"+Chr$(34)+a$+Chr$(34)+"} returns a value of : ",pix
; NPrint ""
; Print " ":WJam 4:NPrint a$
; NPrint ""
; WJam 0:NPrint "So "+Chr$(34)+a$+Chr$(34)+" is ",pix," pixels wide in this WindowFont."
; NPrint "":NPrint "-----------------------------------------------------------------"
; demo 2 :
; a$="Lots and lots and lots and lots and lots and lots and lots and lots and lots and lots of text"
;; try taking out a couple of "and lots" to make it fit!
; NPrint "":NPrint a$
; If PixelLen {a$}>InnerWidth
; NPrint "":NPrint "The string above is too wide!"
; Else NPrint "":NPrint "Yep,that string fits!"
; EndIf
; Repeat
; VWait 5
; Until Event=$200
; End
;-----------------------------------------------------------------
; Function : CentreWindowX { width of window }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns x position for window of width "width.w".
; Use it with CentreWindowY {} to centre a window
; both ways in the CURRENTLY USED screen.
Function.w CentreWindowX {width.w}
x.w=(ScreenWidth/2)-(width/2)
Function Return x
End Function
; demo :
; See demo for CentreWindowY {} !
;-----------------------------------------------------------------
; Function : CentreWindowY { height of window }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns y position for window of height "height.w".
; Use it with CentreWindowX {} to centre a window
; both ways in the CURRENTLY USED screen.
Function.w CentreWindowY {height.w}
y.w=(ScreenHeight/2)-(height/2)
Function Return y
End Function
; demo :
; FindScreen 0
; w=400:h=180
; Window 0,CentreWindowX {w},CentreWindowY {h},w,h,$140f,"I'm in the middle!",1,2
; MouseWait:End
;-----------------------------------------------------------------
; Function : WindowOpened { window }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Although it's possible to do this :
; If Window (0,0,0,640,200,$140f,"",1,2)=0 Then End
; That apparently doesn't work on some people's setups,
; hence this function...returns False (0) if the window isn't
; open.
Function WindowOpened {win.b}
If Peek.l(Addr Window(win))
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
; Screen 0,10
; Window 0,0,0,641,200,$140f,"",1,2
; If WindowOpened {0}=0 Then Request "","Failed to open window!","Abort!":End
; MouseWait:End
;-----------------------------------------------------------------
; Function : WindowFillScreen { window number, flags, title }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; A basic function to open a full-screen window, just below the
; title bar, on the CURRENTLY USED screen - should work for
; ANY screen/font sizes though.
; You may want to edit parts of the function to suit your
; program, eg DPen, BPen, GadgetList and BitMap parameters
; aren't supplied to this function.
Function WindowFillScreen {win.b,flags.l,title$}
*sc.Screen=Peek.l(Addr Screen(Used Screen))
If *sc
If Peek.l(Addr Window(win))
Function Return 0
Else Window win,0,*sc.Screen\BarHeight+1,*sc.Screen\Width,*sc.Screen\Height-(*sc.Screen\BarHeight+1),flags,title$,1,2
If Peek.l(Addr Window(win))=0
Function Return 0
Else Function Return -1
EndIf
EndIf
Else Function Return 0
EndIf
End Function
; demo :
; WbToScreen 0
;; Screen 0,28 ; uncomment to test on another screen...
; If WindowFillScreen {0,$140f,"Hello"}=0
; Request "","Failed to open window!","OK":End
; EndIf
; Request "","Ta-daaa!||A nice full-screen window!","Amazing..."
; End
;-----------------------------------------------------------------
; Function : WindowW { window }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns width of specified window.
Function WindowW {win.b}
*win.Window=Peek.l(Addr Window(win))
If *win
Function Return *win\Width
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0
; Window 0,0,0,640,200,$20140f,"",1,2
; NPrint WindowW {0}
; MouseWait:End
;-----------------------------------------------------------------
; Function : WindowH { window }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns height of specified window.
Function WindowH {win.b}
*win.Window=Peek.l(Addr Window(win))
If *win
Function Return *win\Height
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0
; Window 0,0,0,640,200,$20140f,"",1,2
; NPrint WindowH {0}
; MouseWait:End
;-----------------------------------------------------------------
; Function : WindowFlags { window }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns a value containing the window's flag settings.
; Use "If WindowFlags {window} AND *flag*" to check for
; a particular flag, eg. to check window 0 has a drag bar,
; use "If WindowFlags {0} AND $2 Then BeepScreen 0", etc.
; The flags are listed on page 177 of the Blitz Basic 2.1
; manual (or press Right Amiga + HELP with the cursor on the
; Window command).
Function.l WindowFlags {w.b}
*win.Window=Peek.l(Addr Window(w))
If *win
Function Return *win\Flags
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0
; Window 0,0,0,640,200,$140f,"",1,2
; If WindowFlags {0} AND $2 Then BeepScreen 0 ; check for drag bar
; Request "","Window's flag settings :||$"+Hex$(WindowFlags {0}),"OK"
; End
;-----------------------------------------------------------------
; Function : WinMouseX {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns X position of mouse relative to top-left of
; CURRENTLY USED window (same as WMouseX, but smaller exec
; size will result).
Function.w WinMouseX {}
*win.Window=Peek.l(Addr Window(Used Window))
If *win
Function Return *win\_MouseX
Else Function Return 0
EndIf
End Function
; demo : see demo for WinMouseY{}
;-----------------------------------------------------------------
; Function : WinMouseY {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns Y position of mouse relative to top-left of
; CURRENTLY USED window (same as WMouseY, but smaller exec
; size will result).
Function.w WinMouseY {}
*win.Window=Peek.l(Addr Window(Used Window))
If *win
Function Return *win\_MouseY
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0
; Window 0,0,0,640,200,$140f,"",1,2
; Repeat
; VWait
; WTitle "X : "+Str$(WinMouseX {})+" / Y : "+Str$(WinMouseY {})
; Until Event=$200
; End
;-----------------------------------------------------------------
; Function : LoadScreenFont { font number }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Finds the font of the used screen and loads it into
; the Blitz font object you specify.
; Returns a string containing all of the info, which you can
; parse in your own way if needed ;)
; If it fails to get a screen (ie you haven't created/taken over
; one!) or find the font (shouldn't happen!), it returns ""
; NOTE - to use the font in a window, you MUST call the Blitz
; function WindowFont <window number> afterwards for whichever
; window you want to use the font in (the window must be open!).
Function$ LoadScreenFont {f.w}
*scr.Screen=Peek.l(Addr Screen(Used Screen))
If *scr=0 Then Function Return ""
*scfont.TextAttr=*scr.Screen\Font
If *scfont=0 Then Function Return ""
; In AmigaDOS we trust :
fheight.b=(*scfont.TextAttr\ta_YSize)
fname$=Peek$(*scfont.TextAttr\ta_Name)
LoadFont f,fname$,fheight:Function Return Str$(f)+":"+fname$+":"+Str$(fheight)
End Function
; demo :
; FindScreen 0
; Window 0,0,0,640,150,$20140e,"",1,2
;; NOTE - should really check for LoadScreenFont {} returning
;; an empty string here ( "" ) :
; NPrint ""
; NPrint "LoadScreenFont {0} returns : ",Chr$(34),LoadScreenFont {0},Chr$(34)
; NPrint "[ Format : ",Chr$(34),"Font number:Font name:Font height",Chr$(34)," ]"
; NPrint ""
; NPrint "Still printed using system default font..."
; NPrint ""
; NPrint "[ - Calling WindowFont! - ]"
; WindowFont 0
; NPrint ""
; NPrint "There - printed using screen font - click mouse to end..."
; MouseWait:End
;-----------------------------------------------------------------
; Function : WBWinAddr {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns a memory pointer to the Workbench window.
; Handy for some OS/3rd party library functions,
; (eg requesters).
; W A R N I N G ! ! !
; DO NOT USE YET!!!
; Found out that it returns the first window belonging
; to Workbench (may be a directory window!), not always
; the actual Workbench window... :(
Function.l WBWinAddr {}
wb$="Workbench"
*scr.Screen=LockPubScreen_(&wb$)
If *scr
*win.Window = *scr\FirstWindow
While *win
If *win\Flags & #WFLG_WBENCHWINDOW
If *win\Title=0
Goto poppit
EndIf
EndIf
*win = *win\NextWindow
Wend
Function Return 0 ; didn't get it!
poppit
Function Return *win
Else Function Return 0
EndIf
End Function
; demo :
;; NOTE - this demo isn't much use!
; *win.Window=WBWinAddr {}
; NPrint "Address of WB window : $",Hex$(*win)
; MouseWait:End
;-----------------------------------------------------------------
; Statement : BFWindow { window, left, top, right, bottom, pen }
; Original author : Unknown
; Fixed for gimmezerozero windows by Carl Read :)
; UPDATED (again) By Bippy - BippyM@stingent.freeserve.co.uk
; Now you can (well, have to ;) supply the dimensions and pen
; colour used...much more control :)
; Fills a window with a backfill pattern, like this :
; 010101010101010101010101010101010101
; 101010101010101010101010101010101010
; 010101010101010101010101010101010101
; 101010101010101010101010101010101010
; 010101010101010101010101010101010101
; 101010101010101010101010101010101010
; 010101010101010101010101010101010101
; ...that kind of thing ;)
; Looks all white, like requesters...
; Good when used with WFBox {} - see .WFBox.
; See the end of the statement for how to edit the pattern :)
; WARNING - don't make the right or bottom values you supply
; less than the left or top values... G U R U :)
Statement BFWindow{WindoID.w,WLeft,WTop,WWidth,WHeight,pen}
*Windo.Window = Peek.l(Addr Window(WindoID.w))
USEPATH *Windo
\RPort\AreaPtrn = ?BackFill ;Pattern Address
\RPort\AreaPtSz = 1 ;use 2 arrays form the
;Pattern Address
If \Flags AND $400
WLeft - WLeftOff
WTop - WTopOff
EndIf
;Put a BackFill in the Window.
SetAPen_ \RPort,pen
SetDrMd_ \RPort,1
BltPattern_ \RPort,0,WLeft,WTop,WWidth,WHeight,0
\RPort\AreaPtrn = 0 ;Put it back to 0
\RPort\AreaPtSz = 0 ;Put it back to 0
Statement Return
BackFill:
Dc.w %0101010101010101 ; first line...
Dc.w %1010101010101010 ; next line...
; ;%---------------- ...and repeats all down the window...
; These 0's and 1's control the pattern -
; edit them to change the pattern, but :
; BEWARE : Using the wrong number of 0's and 1's WILL
; crash the machine!!!!!
; Use the -'s as a guide :)
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,320,127,$100e,"Crude backfill demo",1,2
; BFWindow {0,20,20,300,100,2}
; MouseWait:End
;----------------------------------------------------------------
; Statement : WindowTitle { window, window title, screen title }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Changes the title of the specified window (and the screen title
; while the window is activated).
; It's safe to supply a wrong window number - no Enforcer
; hits or anything ;)
Statement WindowTitle { win.b, windowtitle$, screentitle$ }
SetWindowTitles_ Peek.l(Addr Window(win)),&windowtitle$,&screentitle$
End Statement
; demo :
; FindScreen 0
; Window 0,0,11,640,200,$140f,"I'm gonna change soon!",1,2
; Delay_ 100
; WindowTitle {0,"Hello, I've been changed!","Hey, look at me!"}
; MouseWait:End
;-----------------------------------------------------------------
; Statement : WinCls { colour }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Same as WCls, but without the "Oops, I've missed the
; top line" bug (see demo).
Statement WinCls {col.w}
If col>256 Then col=0 ; max value in OS!
SetRast_ RastPort (Used Window),col
End Statement
; ALTERNATIVE VERSION (only uncomment if you comment
; out the above version!)
; Statement : WinCls { window number, colour }
; Statement WinCls { win.b, col.w }
; SetRast_ RastPort (win),col
; End Statement
; This version lets you add the window number - if you
; wanted to clear a load of windows, you'd normally have
; to "Use Window" each one before calling WCls or WinCls{}.
; might come in handy for someone!
; demo :
; FindScreen 0
; Window 0,0,0,640,200,$140f,"",1,2
; WCls 1 ; bugged Blitz command :P
; Request "","Oops - look at the top line of the window!||It hasn't turned to colour 1!","Why, you're right..."
; WinCls {0}
; Request "","OK, let's try again!","OK"
; WinCls {1}
; Request "","That's better!","I vow to use WinCls {} from now on!"
; End
;-----------------------------------------------------------------
; Statement : CleanBorder { window number }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Fixes the window's border's if they've been overdrawn.
; You can check for the borders being messed up by checking
; WaitEvent (or Event) for $4 and then calling this...also,
; if your window gets resized, it can be handy to call this.
Statement CleanBorder {win.b}
If Peek.l(Addr Window(win))
RefreshWindowFrame_ Peek.l(Addr Window (win))
EndIf
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,400,100,$100f,"",1,2
; WBox 0,0,400,100,1
; Delay_25
; WColour 2,1:WLocate WLeftOff,20:NPrint "Yuk! The borders have been overwritten! "
; Delay_150
; CleanBorder {0}
; NPrint "...that's better! Click mouse to end..."
; MouseWait:End
;-----------------------------------------------------------------
; Function : LockWindow { window }
; Locks the specified window, puts up busy pointer.
; Unlocked with the UnLockWindow {} statement.
; IMPORTANT!!! You should store the result as a long
; variable, as in the demo - this is needed for the
; UnLockWindow {} statement!
Function.l LockWindow {win.l}
lock.l=AllocMem_(SizeOf .Requester,1)
If lock
win=Peek.l(Addr Window(win))
InitRequester_(lock)
If Request_(lock,win)
*Exec.Library=Peek.l(4)
If *Exec\lib_Version=>39
Dim tag.TagItem(1)
tag(0)\ti_Tag=#WA_BusyPointer,-1
tag(1)\ti_Tag=#TAG_END
SetWindowPointerA_ win,&tag(0)
EndIf
Else
FreeMem_ lock,SizeOf .Requester
lock=0
EndIf
EndIf
Function Return lock
End Function
; demo : see demo for UnLockWindow {} statement below.
;-----------------------------------------------------------------
; Statement : UnLockWindow { window, lock }
; Unlocks a window locked with the LockWindow {} function.
; IMPORTANT!!!! The "lock" parameter is the value returned
; from LockWindow {} , eg. lock.l=LockWindow {0}
; You supply this value to this statement.
Statement UnlockWindow{win.l,lock.l}
win=Peek.l(Addr Window(win))
*Exec.Library=Peek.l(4)
If *Exec\lib_Version=>39
Delay_ 5
Dim tag.TagItem(0)
tag(0)\ti_Tag=#TAG_END
SetWindowPointerA_ win,&tag(0)
EndIf
EndRequest_ lock,win
FreeMem_ lock,SizeOf .Requester
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,640,100,$40f,"Delayed for 2 seconds",1,2
; GTButton 0,0,0,0,200,10,"Click me!",0
; AttachGTList 0,0
; lock.l=LockWindow {0}
; Delay_ 100
; If lock Then UnlockWindow {0,lock}
; Delay_ 100
; End
;-----------------------------------------------------------------
; Statement : HidePointer { window }
; Author : Serge Veuglers (I think! - from dark.lha on Aminet)
; Hides the mouse pointer for the specified window.
Statement HidePointer {win.w}
*wmem.l = ?EmptyPointer ; gets invisible image from EmptyPointer:
SetPointer_ Peek.l(Addr Window(win)), *wmem, 0,0,1,1
Statement Return ; avoids running into next part...
; The next part is the "invisible image" for the pointer!
EmptyPointer:
Dcb.w 4,$0
End Statement
; demo : see demo for ShowPointer {} statement below.
;----------------------------------------------------------------
; Statement : ShowPointer { window }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Shows the mouse pointer for the specified window, used
; after calling HidePointer {} statement.
Statement ShowPointer {win}
ClearPointer_ Peek.l(Addr Window(win))
End Statement
; demo :
;FindScreen 0
;Window 0,0,0,350,70,$20140e,"Click "+Chr$(34)+"Pointer Off"+Chr$(34)+"!",1,2
;GTButton 0,50,10,0,150,30,"Pointer Off",0
;GTButton 0,51,170,0,150,30,"Pointer On",0
;AttachGTList 0,0
;loop
;Select WaitEvent
; Case $40
; Select GadgetHit
; Case 50
; HidePointer{0}
; WTitle "Click outside to see pointer!"
; Case 51
; ShowPointer{0}
; WTitle "Click "+Chr$(34)+"Pointer Off"+Chr$(34)+"!"
; End Select
; Case $200
; End
;End Select
;Goto loop
;End
;-----------------------------------------------------------------
; Statement : WPrint { x, y, text }
; Author : James L Boyd
; Replacement for "WLocate x,y:Print a$"
; That's right : all of this makes a smaller executable than
; just WLocate & Print!
; Checks for window/screen existence and returns quietly if
; one of them doesn't exist, so no crashes :)
; Can be expanded to include user requirements for "JamMode",
; pen settings and font if you wanted - mail me if you don't
; know how to do it :)
Statement WPrint {x.w,y.w,a$}
*scr.Screen=Peek.l(Addr Screen(Used Screen))
*win.Window=Peek.l(Addr Window(Used Window))
If *win=0 OR *scr=0
Statement Return
EndIf
*rp=*win\RPort
; correct for gimmezerozero windows :
If *win\Flags &$400
x-(*scr\WBorLeft*2)
y-*scr\BarHeight
Else y+1
x-*scr\WBorLeft
EndIf
DEFTYPE.IntuiText text
text\FrontPen=1
text\BackPen=0
text\DrawMode=#JAM1
text\LeftEdge=x
text\TopEdge=y
text\ITextFont=0
text\IText=&a$
text\NextText=0
PrintIText_ *rp,&text,10,10
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,640,100,$20100f,"",1,2
; WPrint {0,0,"Help me"}
; MouseWait:End
;-----------------------------------------------------------------
; Statement : WFBox { window, left, right, top, bottom }
; Clears a 0 (standard : grey) colour bordered box over a
; filled window.
; Good when used with BFWindow {} - see .BFWindow...
; WARNING - don't make the right or bottom values you supply
; less than the left or top values... G U R U :)
; Updated - turned into a statement, because making it
; return a value was pretty pointless. Also uses RectFill_
; instead of BltBitMap_ since it doesn't use a pattern mask.
Statement WFBox {WindoID.w,WLeft.w,WTop.w,WWidth.w,WHeight.w}
*Windo.Window = Peek.l(Addr Window(WindoID))
SetAPen_ *Windo\RPort,0
RectFill_ *Windo\RPort,WLeft,WTop,WWidth,WHeight
SetAPen_ *Windo\RPort,1
Move_ *Windo\RPort,WLeft,WHeight
Draw_ *Windo\RPort,WLeft,WTop
Draw_ *Windo\RPort,WWidth,WTop
SetAPen_ *Windo\RPort,2
Draw_ *Windo\RPort,WWidth,WHeight
Draw_ *Windo\RPort,WLeft,WHeight
End Statement
; demo :
; FindScreen 0
; Window 0,0,0,320,127,$140e,"",1,2
; WCls 3
; WFBox {0,20,20,280,100}
; MouseWait:End
;-----------------------------------------------------------------
.
.Intuition
;-----------------------------------------------------------------
; This section deals with what I can only describe as
; Intuition-related stuff like requesters, and a couple
; of other bits 'n' pieces that didn't really fit into
; the Windows category.
;-----------------------------------------------------------------
; Current routines :
; LockReq { title, body, gadget, type }
; ASLFileRequest { title, path, file, pattern }
; RTReq { title, body text, gadget }
; EasyRequester { window , title, text, gadget(s), flags }
;-----------------------------------------------------------------
; Function : LockReq { title, body, gadget, type }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Locks calling window,puts up requester - standard Request
; (reqtype=0) or RTEZRequest (reqtype=1)
; RTEZRequest does lock the window normally, but if the window
; is closed during the program (eg. during iconify), then
; re-opened,sometimes the requesters fail to lock! hence this
; function ;)
; Of course,you need to have a screen in use to call either
; Request or RTEZRequest.
; tl$=title
; rq$=body text
; gd$=gadget text (as normal - separate more than one gadget
; with "|",eg "OK|Cancel" )
; reqtype=0 for Request,1 for RTEZRequest
Function.b LockReq{tl$,rq$,gd$,reqtype.b}
lock.l=RTLockWindow (Used Window)
If reqtype
rtrq.b=RTEZRequest (tl$,Replace$(rq$,"|",Chr$(10)),gd$)
Else rtrq.b=Request (tl$,rq$,gd$)
EndIf
If lock
RTUnlockWindow Used Window,lock
EndIf
Function Return rtrq
End Function
; demo:
; WBenchToFront_:FindScreen 0
; Window 0,0,0,640,200,$140f,"LockReq Demo - this window is locked!",1,2
; CatchDosErrs
; rt.b=LockReq{"Title","Body text","OK|Quit|Cancel",1}
; NPrint "Gadget pressed : ",rt
; NPrint ""
; NPrint "Press mouse button..."
; MouseWait:End
;-----------------------------------------------------------------
; Function : ASLFileRequest { title, path, file, pattern }
; Author : Paul Burkey - burkey@bigfoot.com
; This function uses OS functions to call up the ASL file
; requester.
; You MUST have a screen in use!
; You can configure the size by altering the top,left,
; width and height variables within the function.
; IMPORTANT NOTE!!! You won't see anything different if you're
; using a patch like RTPatch or MCP's Reqtools Patch function!
Function.s ASLFileRequest{title$,pathname$,filename$,pat$}
*scr.Screen=Peek.l(Addr Screen(Used Screen))
top.w=0
left.w=0
width.w=ScreenWidth/2 ; remove /2 for full-screen requester! ;)
height.w=ScreenHeight
Dim Tags.TagItem(10)
Tags(0)\ti_Tag=#ASLFR_Screen,*scr
Tags(1)\ti_Tag=#ASLFR_InitialPattern,&pat$
Tags(2)\ti_Tag=#ASLFR_TitleText,&title$
Tags(3)\ti_Tag=#ASLFR_InitialFile,&filename$
Tags(4)\ti_Tag=#ASLFR_InitialDrawer,&pathname$
Tags(5)\ti_Tag=#ASLFR_InitialLeftEdge,left
Tags(6)\ti_Tag=#ASLFR_InitialTopEdge,top
Tags(7)\ti_Tag=#ASLFR_InitialWidth,width
Tags(8)\ti_Tag=#ASLFR_InitialHeight,height
Tags(9)\ti_Tag=#TAG_END,0
*filereq.FileRequester=AllocAslRequest_(#ASL_FileRequest,&Tags(0))
If *filereq
ok.l=AslRequest_(*filereq,&Tags(0))
If ok
f$=Peek.s(*filereq\fr_Drawer)
If f$<>"" Then If Right$(f$,1)<>":" AND Right$(f$,1)<>"/" Then f$=f$+"/"
f$=f$+Peek.s(*filereq\fr_File)
EndIf
FreeAslRequest_(*filereq)
EndIf
Function Return f$
End Function
; demo :
; FindScreen 0
; NPrint "You selected: ",ASLFileRequest{"Choose File","s:","shell-startup",""}
; MouseWait
; End
;-----------------------------------------------------------------
; Function : RTReq { title, body text, gadget }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; UPDATE - Curt Esser reported a silly bug in the OpenLibrary_
; call - FIXED.
; Checks for reqtools.library v38 and uses a reqtools
; requester if it's available, defaulting to the standard
; requester if it's not.
; I never made it use the reqtools positioning parameters,
; as these get patched by the user's own prefs settings
; anyway.
Function.b RTReq {title$,body$,gadget$}
lib$="reqtools.library"
*lib.l=OpenLibrary_(&lib$,38)
If *lib
CloseLibrary_ *lib
body$=Replace$(body$,"|",Chr$(10))
rt.b=RTEZRequest (title$,body$,gadget$)
Else rt.b=Request (title$,body$,gadget$)
EndIf
Function Return rt
End Function
; demo :
; If RTReq{"Hello","If you've got reqtools v38+,|I'll be a reqtools requester,|otherwise just a normal one!","OK|Cancel"}
; result.l=RTReq{"Result","You hit OK!","Yep..."}
; Else result.l=RTReq{"Result","You hit Cancel!","Sure did!"}
; EndIf
; End
;-----------------------------------------------------------------
; Function : EasyRequester { win, title, text, gadget(s), flags }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; + Help from David McMinn :)
; Puts up an EasyRequest using the OS - can detect specific
; IDCMP events, eg disk inserted/removed, etc (see p179 of
; the Blitz 2 manual for a list).
; This is essentially the same as RTEZFlagsRequest, but doesn't
; need reqtools.library. The exec size is only slightly
; smaller than when you use RTEZFlagsRequest, but may be useful
; if you want to avoid using reqtools...?
; Either supply a window number (if you've set up a window),
; or you can specify -1 : this uses the Workbench window,
; so that you don't even need a window (or screen) setup
; yourself :)
; You also supply the title, body text and gadget text (all
; just like you do for Request (), and finally any IDCMP
; flags you want to satisfy the requester, eg. $400 for any
; keypress (see p179 of manual). Mutiple flags can be detected
; by doing $400|$8 (key pressed or mouse button hit), etc...
; Multiple flags always return ALL of the flags though, not
; the one that answered the requester (same happens with
; RTEZFlagsRequest).
; To use as a normal requester, just put a flag of 0...but
; make sure you don't supply "" as the gadget, or you're stuck ;)
; It returns gadget numbers just like Request...
; Note, you can supply "" for the gadget, so that your user
; MUST do as they're told (eg insert disk, etc ;) ...NOT
; RECOMMENDED though!!!!
Function.l EasyRequester {win,title$,body$,gadget$,flags.l}
DEFTYPE.EasyStruct es
; this is the work of a genius ;)
If win<>-1 ; -1 - use WB window
*win.Window=Peek.l(Addr Window(win))
Else
wb$="Workbench"
*scr.Screen=LockPubScreen_(&wb$)
If *scr
*win.Window = *scr\FirstWindow
While *win
If *win\Flags & #WFLG_WBENCHWINDOW
wb.b=-1
Goto popit
EndIf
*win = *win\NextWindow
Wend
popit
UnlockPubScreen_ 0,*scr
If wb=0 Then Function Return 0
EndIf
EndIf
If body$="" Then Function Return -1
body$=Replace$ (body$,"|",Chr$(10))
es\es_StructSize=SizeOf.EasyStruct
es\es_Flags=0
es\es_Title=&title$
es\es_TextFormat=&body$
If gadget$=""
es\es_GadgetFormat=0
Else es\es_GadgetFormat=&gadget$
EndIf
Function Return EasyRequestArgs_ (*win,&es,&flags,0)
End Function
; demo :
;; Insert a disk in any drive (works for ANY type of disk, even
;; CDs!) to continue, or click on gadget to abort...
;; Try changing "Abort" gadget to "" !
;; LOOK, NO SCREEN OR WINDOW (that's what the -1 does :)
; If EasyRequester {-1,"","Insert disk in drive...","Abort",$8000}=$8000
; Request "","That's it!","OK"
; Else Request "","You aborted!","Oh..."
; EndIf
; End
;-----------------------------------------------------------------
.
.Graphics
;----------------------------------------------------------------
; This section deals with graphics-related routines, like
; picture/palette loading, depth->colour conversion, etc.
;-----------------------------------------------------------------
; Current routines :
; CheckPic { picture file }
; PicSafe { picture file, type, safety }
; Planes2Cols { number of bitplanes }
; SavePaletteFile { bitMap number, filename }
; GetPaletteSize { palette name }
; UsePalette { screen, palette }
;-----------------------------------------------------------------
; Function : CheckPic { picture file }
; Author : Curt Esser - camge@ix.netcom.com
; This function tests a picture file and returns a string
; telling you what kind of file it is.
; Handy for avoiding crashes when your user tries to load
; a non-IFF image!
; The returned string will be one of the following :
; "OK" = normal ILBM pic
; "GIF" = GIF pic
; "JPEG" = Jpeg pic
; "HAM" = ILBM/Ham pic
; "ANIM" = Animation
; "24bit" = -1 Colour picture
; "????" = Unrecognized file type
; "NF" = File not found
Function.s CheckPic {picpath$}
error$=""
If ReadFile(0,picpath$) ; read file header
FileInput 0
header$ = Inkey$(2000) ; read 2000 bytes
CloseFile 0
PopInput
If Left$(header$,4)<> "FORM" OR Mid$(header$,9,4) <> "ILBM"
; ^ Checks if it's IFF...if it's not an IFF, do this :
If Left$(header$,3)="GIF" Then error$="GIF "
If Mid$(header$,7,4)="JFIF" Then error$="JPEG"
If Mid$(header$,9,4)="ANIM" Then error$="ANIM"
If error$="" Then error$="????"
Else ; valid IFF header found!
x.w=Instr(header$,"CAMG") ; check if it's a HAM pic
If x<>0
a$=Left$(Right$(Hex$(Peek.l(&header$+x+7) AND $88A4),3),1)
If a$="8" Then error$="HAM "
EndIf
x=Instr(header$,"CMAP") ;check for 24 bit pic!
If x=0 Then error$="24bit"
EndIf
If error$="" Then error$="OK" ; yep, it's an IFF file!
Else ; couldn't even find the file!
error$="NF"
EndIf
Function Return error$
End Function
; demo :
;; WARNING!!! You should insert the name of a file on YOUR
;; system before running this, in the CheckPic{}
;; part...
; Request "","File format : "+CheckPic{"art:jpegs/santa.jpg"},"OK"
; End
;----------------------------------------------------------------
; Function : PicSafe { picture file, type, safety }
; Author : Curt Esser - camge@ix.netcom.com
; Checks if there's enough chip memory to load a shape
; or bitmap.
; The function returns a long value :
; 1) True (-1) if you can go ahead and load it
; 2) The number of bytes needed if there's not enough
; See demos...
; The loadtype.b parameter should be :
; 1) 0 if you're testing a bitmap
; 2) 1 if you're testing a shape...
; The safety.l parameter allows you to leave a certain
; amount of memory (bytes) as a safety margin (I'd use
; at least 50000 normally)...this is the bare minimum of
; chip mem to leave available after loading the picture.
Function.l PicSafe{picpath$,loadtype.b,safety.l}
ILBMInfo picpath$ ;read the pictures size information
picDepth.w=ILBMDepth
picDepth + loadtype ;a shape needs an extra bitplane
picHeight.w=ILBMHeight
picWidth.w=ILBMWidth
planemem.l=picHeight*picWidth/8 ;bytes needed for 1 bitplane of this pic
totalmem.l=planemem*picDepth ;total bytes needed for loading
If AvailMem_ (131074)>totalmem+safety Then ok.l=-1 Else ok=totalmem
; you can replace 131074 with #MEMF_CHIP|#MEMF_LARGEST
; if you have Blitzlibs:amigalibs.res in Compiler Options...
Function Return ok
End Function
; demo :
;; WARNING!!! You should insert the name of a file on YOUR
;; system before trying to run this!
; result.l=PicSafe{"art:misc/santa.iff",0,50000}
;; the above call uses 0 to check a bitmap, and 50000 bytes
;; of safety memory.
; If result=-1
; Request "","OK to load picture!","OK"
; Else Request "","Not enough chip memory to load picture!|Needs "+Str$(a)+" bytes!","Abort!"
; EndIf
; End
; demo 2 :
;; DON'T RUN THIS!!! Just an alternative way of using it.
; pic$="art:misc/santa.iff"
; If PicSafe{pic$}=-1 Then LoadBitMap 0,pic$,0
; MouseWait:End
;-----------------------------------------------------------------
; Function : Planes2Cols { number of bitplanes }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns the number of colours available
; in the number of bitplanes given.
Function.w Planes2Cols {planes.b}
colours.w=2^planes
Function Return colours
End Function
; demo :
; Print "An 8-plane bitmap has ",Planes2Cols {8}," colours."
; MouseWait:End
; demo 2 :
;; WARNING!!! DO NOT RUN!
;; This is an example of how it could be used...
; cols.w=Planes2Cols {ILBMDepth} ; how many colours in currently
; ; examined picture?
;-----------------------------------------------------------------
; Statement : SavePaletteFile { bitmap number, filename }
; Author - "Cyanure"?
; Saves the palette from a given bitmap to a file as a
; standard Amiga IFF palette.
; I think you have to use LoadBitMap with the palette
; parameter (or load the palette manually), then call
; this statement.
Statement SavePaletteFile {NumberBmap.b,FileName.s}
DEFTYPE .b NumberPlanes
DEFTYPE .w NumberColors,FSize
NumberPlanes=Peek.b(Addr BitMap(NumberBmap)+5)
NumberColors=2^NumberPlanes
FSize=3*NumberColors+48 ; File size
If OpenFile(1,FileName.s)=-1
*pf=AllocMem_(FSize,0) ; Memory for the palette file
*pf0=*pf ; Beginning of the palette file
address
Poke.l *pf,$464f524d ; FORM
Poke.l *pf+4,FSize-8 ;
Poke.l *pf+8,$494c424d ; ILBM
Poke.l *pf+12,$424d4844 ; BMHD
Poke.l *pf+16,20 ; Size of the BMHD chunk
Poke.l *pf+20,0 ; width and height
Poke.l *pf+24,0 ; x and y
Poke.l *pf+28,$03020180 ; I don't know why but it works !
Poke.l *pf+32,0 ; transparency and aspect
Poke.l *pf+36,0 ; page width and page height
Poke.l *pf+40,$434d4150 ; CMAP
Poke.l *pf+44,NumberColors*3 ; Size of the CMAP chunk
*pf+48 ; Increases the pointer
For c=0 To NumberColors-1
Poke.b *pf,AGARed(c)
Poke.b *pf+1,AGAGreen(c)
Poke.b *pf+2,AGABlue(c)
*pf+3
Next c
WriteMem 1,*pf0,FSize ; Writes in file #1
FreeMem_ *pf0,FSize
CloseFile 1
EndIf
End Statement
demo :
; NOTE : DO NOT run this demo as it requires specific
; files - you'll have to replace all the filenames with some
; from your own system before running!
; The demo is from the original source by Cyanure.
; WBStartup
; NoCli
; ; I suppose the palette you want to save is one of an open bitmap
; ; So, I open such a bitmap :
; Screen 0,0,0,320,256,8,0,"title",1,2
; ScreensBitMap 0,0
; LoadBitMap 0,"art:misc/amilogo.iff",0 ; chooses a bitmap
; LoadPalette 0,"art:misc/amilogo.iff"
; Use Palette 0
; SavePaletteFile{0,"ram:PaletteStd.col"}
; End
;-----------------------------------------------------------------
; Function : GetPaletteSize { palette name }
; Returns the number of colours in a given palette.
; NOT guaranteed to be future-proof, but I don't suppose
; we need to worry about that now, do we? ;)
; NOTE - not sure how reliable this is...
; I found this somewhere (or maybe it was sent to me?)
; Thought it would be useful to somebody, so I've chucked it
; in with nearly no changes (could be optimised to use OS file
; reading though... :)
Function.w GetPaletteSize{palname$}
numbitplanes.w=0
If ReadFile(0,palname$)
FileSeek 0,28
ReadMem 0,&numbitplanes,1
CloseFile 0
End If
Function Return 2^numbitplanes
End Function
; demo :
;; NOTE : change the palette name to one on YOUR system!
; NPrint GetPaletteSize {"sys:storage/clickforcolours"}
; MouseWait:End
;-----------------------------------------------------------------
; Statement : UsePalette { screen, palette }
; Author : Paul Burkey - burkey@bigfoot.com
; Same as Use Palette, but using OS functions (smaller
; executable size). Also has some other advantage, but I've
; forgotten what it was!
Statement UsePalette{scr.w,pal.w}
LoadRGB32_ ViewPort(scr),Peek.l(Addr Palette(pal))
End Statement
; demo :
; FindScreen 0,"Workbench Screen"
;; WARNING!!! This will screw up your Workbench palette
;; and I can't be bothered typing stuff to set it back!
;; You may want to edit this before running ;)
; LoadPalette 0,"Sys:Storage/clickforcolours"
; if Request ("","I'm gonna change the screen colours!","OK|NO!")
; UsePalette {0,0}
; Delay_ 100
; EndIf
; End
;----------------------------------------------------------------
.
.Sound
;----------------------------------------------------------------
; This section deals with sound-related routines, such as
; safe loading, timing,etc.
;-----------------------------------------------------------------
; Current routines :
; SoundSafe { sound file, safety }
; SaveSound { sound number, filename }
; SoundTime { sound number }
;-----------------------------------------------------------------
; Function : SoundSafe { sound file, safety }
; checks a sound sample :
; 1) To see if it's really an IFF sample
; 2) To check there's enough memory to load it
; The safety.l parameter is the number of bytes of safety
; margin to add on...ie the bare minimum of chip mem to leave
; available after loading the sound. I'd use about 50000
; normally.
; Returns a long value depending on the results :
; 1) True (-1) if it's OK to load the sample
; 2) the number of bytes needed if chip memory's too low
; 3) False (0) if it's not an IFF sample
; 4) 1 if it's not found...bit hacky, but pretty safe!
; see demos...
Function.l SoundSafe {soundpath$,safety.l}
If ReadFile(0,soundpath$) ; check file header
FileInput 0
header$ = Inkey$(12) ; read 12 bytes
CloseFile 0
PopInput
If Left$(header$,4)="FORM" AND Right$(header$,4)="8SVX"
;valid sample, now check chip memory
chipmem.l=FileSize(soundpath$) ; memory needed
If AvailMem_ (131074)>chipmem+safety Then ok.l=-1 Else ok=chipmem
Else
ok=0 ; not an IFF sample!
EndIf
Else
ok=1 ; not found!
EndIf
Function Return ok
End Function
; demo :
;; NOTE that you need to change the filename to one on your
;; own system!
; result.l=SoundSafe{"sys:storage/goodjob.iff",50000}
;; the above call uses 50000 bytes of safety margin.
; Select result
; Case -1
; message$="OK to load sound!"
; Case 0
; message$="Not an IFF sample!"
; Case 1
; message$="Not found!"
; Default
; message$="Not enough memory - need "+Str$(result)+" bytes!"
; End Select
; Request "",message$,"OK"
; End
; demo 2 :
;; quick call! NOTE - change the filename to one
;; on your system!
; If SoundSafe{"sys:storage/goodjob.iff",50000}=-1
; LoadSound 0,"sys:storage/goodjob.iff"
; Else End
; EndIf
; MouseWait:End
;-----------------------------------------------------------------
; Function : SaveSound { sound number, filename }
; Author : Curt Esser - camge@ix.netcom.com
; AT LAST! Blitz Basic gets a sample SAVE routine!
; Full credit to Curt Esser for this excellent routine!
; Right, who's gonna make an IFF sample editor?!
; Come on, we've got LoopSound, InitSound, SoundData, PeekSound,
; etc, so it shouldn't be too hard to make it! (I'm too lazy ;)
; UPDATE - demo fixed by Curt - it never checked for a failure
; properly before!
Function.b SaveSound{samplenumber.w,saveIFF$}
If Peek.l(Addr Sound(samplenumber)) ;make sure sample exists
; Now we read the necessary information into our variables
sndstart.l=Peek.l(Addr Sound(samplenumber)) ;start of sample data
slen.l=(Peek.w(Addr Sound (samplenumber)+6) AND $FFFF)*2 ;bytes of sample data
; -- the total disk file length less 8 bytes for "FORM" + length:
tlen.l=slen+40
; -- the looping information:
loop.l=Peek.l(Addr Sound (samplenumber)+8) ;start of looping part
lpln.l=(Peek.w(Addr Sound (samplenumber)+12) AND $FFFF)*2 ;length of loop
ones.l=loop-sndstart ;length of 1 shot part
cycl.l=32 ;seems to be standard?
; -- the frequency:
per.l=(Peek.w(Addr Sound(samplenumber)+4) AND $FFFF) ;the sample period
persec.w= 3579440/per ;the actual frequency
If WriteFile (0,saveIFF$)
error=-1
FileOutput 0
Print "FORM" ;start of IFF header
WriteMem 0,&tlen,4 ;total bytes following the header
Print "8SVXVHDR" ;8svx sample ID, and start of Voice Header
temp.l=20
WriteMem 0,&temp,4 ;bytes in Voice Header chunk
WriteMem 0,&ones,4 ;data bytes in 1 shot part
temp.l=0
WriteMem 0,&lpln,4 ;for looping (length of loop)
WriteMem 0,&cycl,4 ;" " "
WriteMem 0,&persec,2 ;frequency of the sample
tempb.b=1
WriteMem 0,&tempb,1 ;octaves
WriteMem 0,&temp,1 ;compression (we use 0 = not compressed)
temp.l=65536 ;volume (full volume)
WriteMem 0,&temp,4
Print "BODY" ;start of Body chunk
WriteMem 0,&slen,4 ;bytes of actual sample data
WriteMem 0,sndstart,slen ;OK, finally! Write the data
CloseFile 0
Use Window 0
Else ;DOS error - could not save the file!
error=1
EndIf
Else
error=0 ;sorry, that sample doesn't exist!
EndIf
Function Return error
End Function
; demo :
;; DO NOT run this demo until you've replaced the sample
;; names given!
; LoadSound 0,"ram:test.iff"}
; Delay_ 100 ; shouldn't be needed, but just in case...!
; ok.b=SaveSound {0,"ram:copy_of_test.iff"}
; Select ok ;if ok<>-1 an error occurred!
; Case 0
; Request "","You don't have a sample loaded ","Doh!"
; Case 1
; Request "","Disk error - sample not saved","OH NO!"
; End Select
; End
;-----------------------------------------------------------------
; Function SoundTime { sound number }
; Author : Curt Esser - camge@ix.netcom.com
; Returns number of vblanks taken to play the given
; sound at the default rate.
Function.w SoundTime {snd.w}
If NTSC=-1
vrate.b=60
Else
vrate.b=50
EndIf
period.w=Peek.w(Addr Sound (snd)+4) ;get the period from sound object
l.l=Peek.w(Addr Sound (snd)+6) ;get the length from sound object
If l<0 Then l+64000 ;correct for unsigned value if needed
lngth.l=l*2 ;convert to true length of sample
frequency.f = 3579440/period ;convert to true frequency
delay.w=lngth/(frequency/vrate) ;convert to playing time in VBlanks
delay+5 ;add a bit of padding for short samples
Function Return delay
End Function
; demo :
;; IMPORTANT!!! Alter filename below to a sample on your disk!
; LoadSound 0,"sys:storage/goodjob.iff"
; NPrint ""
; NPrint "Playing sample..."
; NPrint ""
; Sound 0,15
; VWait SoundTime{0} ; wait until sample has finished before printing info :
; NPrint "Sound 0 uses ",SoundTime{0}," vblanks..."
; MouseWait:End
;-----------------------------------------------------------------
.
.Hardware
;----------------------------------------------------------------
; This section deals with routines which find hardware
; information, as well as routines which directly access
; hardware instead of using the OS (and therefore might
; not be future-compatible).
; Where this is the case, I've marked the routines with :
; "NOTE - Direct hardware access (may not be future-compatible)."
;-----------------------------------------------------------------
; Current routines :
; GoNTSC {}
; GoPAL {}
; FilterOn {}
; FilterOff {}
; ChipSet {}
; Unhook { device: }
; Hookup { device: }
; IsAGA{}
; GetCPU {}
; GetFPU {}
; KeyCodeR {}
; NewNTSC {}
;-----------------------------------------------------------------
; Statement : GoNTSC {}
; Blitz's ForceNTSC causes an Enforcer hit - this doesn't :)
; NOTE - Direct hardware access (may not be future-compatible).
Statement GoNTSC {}
MOVE #0,$dff1dc
End Statement
; demo :
; See GoPAL{}
;-----------------------------------------------------------------
; Statement : GoPAL {}
; Blitz's ForcePAL causes an Enforcer hit - this doesn't :)
; NOTE - Direct hardware access (may not be future-compatible).
Statement GoPAL {}
MOVE #32,$dff1dc
End Statement
; demo :
;; NOTE that this demo calls GoNTSC {} as well.
; If NTSC
; Request "","Going into PAL mode for two seconds...","OK"
; GoPAL {}
; Delay_100
; GoNTSC {}
; Else
; Request "","Going into NTSC mode for two seconds...","OK"
; GoNTSC {}
; Delay_100
; GoPAL {}
; EndIf
; End
;-----------------------------------------------------------------
; Statement : FilterOn {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Switches hardware filter on, like "Filter", but saves
; a tiny amount on executable size ;)
; Switching the filter on cuts out higher frequencies,
; making the sound more muffled, but reducing noise.
; NOTE : If you must use the Filter command still, the
; "controls" are reversed! "Filter On" turns it off,
; and vice versa!
; NOTE - Direct hardware access (may not be future-compatible).
Statement FilterOn {}
Poke.b $bfe001,0
End Statement
; demo : see demo for FilterOff {}
;-----------------------------------------------------------------
; Statement : FilterOff {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Switches hardware filter off, like "Filter", but saves
; a tiny amount on executable size ;)
; NOTE : If you must use the Filter command still, the
; "controls" are reversed! "Filter On" turns it off,
; and vice versa!
; NOTE - Direct hardware access (may not be future-compatible).
Statement FilterOff {}
Poke.b $bfe001,2
End Statement
; demo :
;; NOTE: Replace "goodjob.iff" with a sample on YOUR
;; hard drive!
; LoadSound 0,"sys:storage/goodjob.iff"
; FilterOn {}
; Sound 0,15
; Delay_100
; FilterOff {}
; Sound 0,15
; Delay_100
; End
;-----------------------------------------------------------------
; Function : ChipSet {}
; Returns a string according to chipset in the
; Amiga it's run on (OCS/ECS/AGA/AAA(!)/Unknown).
; NOTE - Direct hardware access (may not be future-compatible).
; I THINK this does direct hardware access anyway - the Lisa
; command deals with finding the chipset.
Function.s ChipSet {}
chip.w=Lisa
Select chip
Case $00
chip$="OCS"
Case $F7
chip$="ECS"
Case $F8
chip$="AGA"
Case $F9
chip$="AAA (Prototype)"
Default
chip$="unknown"
End Select
Function Return chip$
End Function
; demo :
; Request "","This is an "+ChipSet{}+" Amiga!","OK"
; End
;-----------------------------------------------------------------
; Function : Unhook { device: }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; "Unplugs" the specified drive.
; IMPORTANT!!! This function can be very dangerous if you
; don't know what you're doing!!!
; Don't call it on the DISK's name, call it on the
; DEVICE name (if you don't know what that means, you shouldn't
; be using this!)...using the disk name will "busy" the disk,
; but won't be able to "reconnect" it (see Hookup{} function)
; because the OS asks you to insert the disk (whereas it won't
; ask for the device). Therefore this returns 0 if you try
; to do that.
Function.b Unhook {device$}
If DeviceName$(device$)=device$ Then Function Return 0
If Inhibit_(&device$, -1)
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
; The demo's in the Hookup {} demo section...
;-----------------------------------------------------------------
; Function : Hookup { device: }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; "Reconnects" the specified drive, disconnected with
; Unhook {}.
; IMPORTANT!!! This function can be very dangerous if you
; don't know what you're doing!!!
; Don't call it on the disk's name, call it on the
; DEVICE name (if you don't know what that means, don't
; mess with it!)...see Unhook{} function.
Function.b Hookup {device$}
If Inhibit_(&device$, 0)
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
;; WARNING!!! Do NOT test until you've saved all work!!!
; NoCli
; dr$="SYS:"
; r$="WARNING!!!||This demo will make your "+dr$+" partition BUSY for a while!||Click on Cancel to Abort!||Click on OK "
; r$+"if all work is saved...||You'll have to reboot if it fails to reconnect the drive!"
; If Request ("",r$,"OK|Cancel")=0 Then End
; If Unhook {dr$}
; Request "","Go and try to access the "+dr$+" drive before|you click on OK...","OK"
; If Hookup {dr$}=0 Then Request "","* Failed! *||Uh-oh...I'd better re-boot!","Reboot":ColdReboot_
; EndIf
; End
;-----------------------------------------------------------------
; Function : IsAGA{}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns True (-1) if it's an AGA machine. This makes for
; a much smaller executable than CheckAGA (around half-size :)
; Note that AGA is only activated after AGA machines have
; their SetPatch program run!
Function.b IsAGA {}
lib$="graphics.library"
*gfxbase.GfxBase=OpenLibrary_(&lib$,33)
If *gfxbase
If *gfxbase\ChipRevBits0 AND #GFXB_AA_ALICE
aga.b=-1
Else aga=0
EndIf
CloseLibrary_ *gfxbase
EndIf
Function Return aga
End Function
; demo :
; If IsAGA{} Then Request "","AGA!","OK" Else Request "","Non-AGA!","OK"
; End
;; That's right! All of the above, including the function itself, gives
;; a smaller executable than this :
; If CheckAGA Then Request "","AGA!","OK" Else Request "","Non-AGA!","OK"
; End
;; Compile 'em separately and see :)
;-----------------------------------------------------------------
; Function : GetCPU {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns the type of (68k!) processor installed in the system.
; Return values :
; 0 = 68000
; 1 = 68010
; 2 = 68020
; 3 = 68030
; 4 = 68040 ; note - no 5! ;)
; 6 = 68060
Function.b GetCPU {}
cpu.b=0
*e.ExecBase = Peek.l(4)
#AFF_68060=(1 LSL 7) ; flag for 060, not in Blitz includes
If *e
If *e\AttnFlags & #AFF_68010 ; gotta do it like this,
If *e\AttnFlags & #AFF_68020 ; cos each processor has the
If *e\AttnFlags & #AFF_68030 ; flags of the previous processor
If *e\AttnFlags & #AFF_68040 ; set, too...
If *e\AttnFlags & #AFF_68060
cpu=6
Else cpu=4
EndIf
Else cpu=3
EndIf
Else cpu=2
EndIf
Else cpu=1
EndIf
Else cpu=0
EndIf
EndIf
Function Return cpu
End Function
; demo :
; NPrint "You have a 680",GetCPU{},"0 processor..."
; MouseWait:End
;-----------------------------------------------------------------
; Function : GetFPU {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns the type of FPU (if any) installed in the system.
; Return values :
; 0 = No FPU
; 1 = 68881 FPU
; 2 = 68882 FPU
; 3 = 68040 FPU (no math emulation) ; 040.library not loaded
; 4 = 68040 FPU (math emulation)
; 5 = 68060 FPU (no math emulation) ; 060.library not loaded
; 6 = 68060 FPU (math emulation)
Function.b GetFPU {}
fpu.b=0
*e.ExecBase = Peek.l(4)
#AFF_68060=(1 LSL 7)
If *e
If *e\AttnFlags & #AFF_68881
If *e\AttnFlags & #AFF_68882
fpu=2
Else fpu=1
EndIf
If *e\AttnFlags & #AFF_FPU40
fpu=4 ; 68040 FPU (math emulation)
If *e\AttnFlags & #AFF_68060 ; check for 060...
fpu=6 ; 68060 FPU (math emulation)
EndIf
EndIf
Else fpu=0 ; No 68881 or 68882
If *e\AttnFlags & #AFF_FPU40 ; check if it's an 040 without 6888x emulation...
fpu=3 ; 68040 FPU (no math emulation)
If *e\AttnFlags & #AFF_68060 ; check for 060...
fpu=5 ; 68060 FPU (no math emulation)
EndIf
EndIf
EndIf
EndIf
Function Return fpu
End Function
; demo :
; Select GetFPU{}
; Case 0
; fpu$="None"
; Case 1
; fpu$="68881"
; Case 2
; fpu$="68882"
; Case 3
; fpu$="68040 FPU (no math emulation)"
; Case 4
; fpu$="68040 FPU (math emulation)"
; Case 5
; fpu$="68060 FPU (no math emulation)"
; Case 6
; fpu$="68060 FPU (math emulation)"
; End Select
; NPrint "Your FPU type : ",fpu$
; MouseWait:End
;-----------------------------------------------------------------
; Function : KeyCodeR {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; NOTE - this is adapted from Paul Bowlay's BlitzOp.guide.
; Size-saving replacement for KeyCode.
; A test program using Blitz's "KeyCode" turned out an
; executable of 19 K/bytes; replacing KeyCode with this
; function resulted in an executable of 3 K/bytes!
; Unlikely to be future-proof, since it reads the hardware
; directly, but then, I'd guess KeyCode does too ;)
; NOTE - Direct hardware access (may not be future-compatible).
Function.w KeyCodeR {}
Function Return Peek($bfec00) AND $ff
End Function
; demo :
;; IMPORTANT!!! Click outside the Blitz CLI window before
;; pressing any keys, or you'll just stop the CLI output!
;; press ESCAPE to stop!
; Repeat
; VWait
; e.w=KeyCodeR {}
; NPrint e
; Until e=117
; End
;-----------------------------------------------------------------
; Function : NewNTSC {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Exec-size saving replacement for NTSC.
Function.b NewNTSC {}
lib$="graphics.library"
*gb.GfxBase=OpenLibrary_(&lib$,0)
If *gb
If *gb\DisplayFlags AND #REALLY_PAL Then p.b=0 Else p=-1
CloseLibrary_ *gb
EndIf
Function Return p
End Function
; demo :
; If NewNTSC {}
; NPrint "NTSC machine."
; Else NPrint "PAL machine."
; EndIf
; MouseWait:End
;-----------------------------------------------------------------
.
.Strings
;----------------------------------------------------------------
; This section contains routines which manipulate strings in
; some way.
;-----------------------------------------------------------------
; Current routines :
; Quoted { text }
; StripToDot { filename }
; Value { number as string }
; SLen { string }
;-----------------------------------------------------------------
; Function : Quoted { text }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Puts quotes around a file name,so that if your user has
; entered a file name containing spaces,it'll still be OK.
; Useful for some file requester returned strings,or appicons.
Function.s Quoted{a$}
a$=Chr$(34)+a$+Chr$(34)
Function Return a$
End Function
; demo :
; Print "Enter a file name containing spaces : "
; f$=Edit$(30)
; NPrint "":NPrint Quoted{f$}
; MouseWait:End
;-----------------------------------------------------------------
; Function : StripToDot { filename }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; UPDATED by Nick Clover - nick@bauk.freeserve.co.uk
; - small optimisation!
; I use this in a program to strip file extensions off.
; eg. doing StripToDot{"reqtools.library"} would return
; just "reqtools".
; NOTE : some files will have more than one dot (period) !
Function.s StripToDot{a$}
For a.w=Len(a$) To 1 Step -1
If Mid$(a$,a,1)="." Then a$=Left$(a$,a-1):a=1
Next a
Function Return a$
End Function
; demo :
; Print "Enter a string with an extension (eg help.txt) : "
; a$=StripToDot{Edit$(25)}
; NPrint "":Print "New name : ",a$
; NPrint "":NPrint "Click the mouse to end..."
; MouseWait:End
; demo 2 :
;; I use it along with StripFile{} to just return
;; the file part of a path & file (eg "Work:Pics/Amiga.iff"
;; will be returned as "Amiga".
; a$=StripToDot{ StripFile{"Work:Pics/Amiga.iff"} }
; NPrint a$:MouseWait:End
;-----------------------------------------------------------------
; Function : Value { number as string }
; Author : Curt Esser - camge@ix.netcom.com
; This function returns correct values
; for very large numbers - Blitz doesn't!
; Probably saves quite a bit on executable size too.
Function.l Value {input$}
valu.l=0
chars.w=StrToLong_(&input$,&valu)
Function Return valu
End Function
; demo :
; test$="1087504386"
; NPrint "Blitz's Val : ",Val(test$)
; NPrint "Value{} function : ",Value{test$}
; MouseWait
; End
;-----------------------------------------------------------------
; Function : SLen { string }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Executable-size-saving replacement for Len ().
Function.l SLen{a$}
stlen.l=Peek.l(&a$-4)
Function Return stlen
End Function
; demo :
; NPrint SLen{"Hello"}
; MouseWait:End
;-----------------------------------------------------------------
.
.FileIO
;----------------------------------------------------------------
; This section contains routines that involve disk
; or file access in general.
;-----------------------------------------------------------------
; Current routines :
; ShowInfo { directory, icon, screen number }
; StripFile { path & file name }
; CreateDir { new directory }
; CheckLib { library, version }
; OSAssign { assign name, path, type }
; Del { file }
; OpenShell { x, y, width, height, title, flag(s) }
; Name { old file name, new name For File }
; FileTime { filename }
; FileDate { filename }
; SetComment { filename, comment }
; ReadComment { filename }
; Exist { filename }
; CompareDates { file 1, file 2 }
; RunFromWB { program }
; ShowWhy {}
; SetProtect { file, flags }
; AskForDisk { disk name }
; DelIcon { icon }
;-----------------------------------------------------------------
; Statement : ShowInfo { directory, icon, screen number }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Puts up the icon information requester (or replacement like
; SwazInfo/WBInfo) onto the requested screen.
; You supply :
; 1) The directory of the file,
; 2) The file name (IMPORTANT!!! DO NOT add .info onto the end!!!)
; also, the file doesn't have to have its own icon.
; 3) The screen number - therefore, you have to have a screen
; in use, but it can use ANY Intuition screen :)
; NOTE : For some reason, the icon information requester
; still pops up if you give it a non-existent file!
Statement ShowInfo {dir$,icon$,skreen.b}
*scr.Screen=Peek.l(Addr Screen(skreen)) ; get screen structure for wbinfo_() call
*lok.l=Lock_(&dir$,#ACCESS_READ) ; get a lock on the directory for the call
If *scr ; make sure we've got a screen structure
If *lok ; and a directory lock
If WBInfo_(*lok,&icon$,*scr) ; the Icon Info call!
Else Request "","Error showing icon information!","Oh..."
EndIf
UnLock_ *lok ; free our directory lock
Else Request "","Couldn't get lock on directory!","Oh..."
EndIf
Else Request "","Doh!||The programmer has asked for a non-existent screen!","Duh..."
EndIf
End Statement
; demo :
; WBenchToFront_ : FindScreen 0 ; needed for requester
; ShowInfo {"c:","copy",0}
; End
;-----------------------------------------------------------------
; Function : StripFile { path & file name }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns the file part of a path & file string,eg from a
; reqtools file requester or an appicon.
Function.s StripFile{p$}
*fileptr.l = FilePart_(&p$)
f$=Peek$(*fileptr)
Function Return f$
End Function
; demo :
; MaxLen f$=192 ; needed for RTEZLoadFile
; FindScreen 0 ; same here
; a$=RTEZLoadFile("Select file",f$)
; If a$="" Then End
; Request "","The file part of "+a$+"|is : "+StripFile{a$},"OK"
; End
;-----------------------------------------------------------------
; Function : CreateDir { new directory }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Tries to create a new directory. You have to supply the full
; path name of the directory you want to create.
; Returns False (0) for a failure (try doing Exists() on the
; directory you're trying to create - it may already exist.
Function.l CreateDir{dir$}
*lock.l = CreateDir_(&dir$)
If *lock
UnLock_ *lock
EndIf
Function Return *lock
End Function
; demo :
; If CreateDir{"Ram:Test"}
; NPrint "New drawer created!"
; Else NPrint "Failed to create new drawer..."
; If Exists ("Ram:Test") Then NPrint "Drawer already exists!"
; EndIf
; End
;-----------------------------------------------------------------
; Function : CheckLib { library, version }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; copied from suggestion by Paul Burkey ;)
; Minor bugfix (was harmless) - changed OpenLibrary_() result's
; type to .Library instead of .l, which is how it's meant to be!
; Checks library versions.
; Throw it at the start of your code,then do :
; getit.Library=CheckLib {"some.library",version}
; ...where "some.library" is the library you need to check for,
; and version is the version number you need (0 if it doesn't
; matter)...
; It returns True (-1) for success, False (0) for fail...duh... ;)
; NOTE : Don't use subversions for the version number -
; you can only use integers (this is an OS rule, not mine!),
; eg for madeup.library v2.21 you would call :
; x.Library = CheckLib {"madeup.library",2}
; Just repeat that call for each library you need.
; Use SnoopDos to see if your program requires a particular
; version,otherwise you can usually just use 0.
Function.b CheckLib {lib$,libv.w}
*lib.Library=OpenLibrary_(&lib$,libv)
If *lib
CloseLibrary_ *lib
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
; lib$="reqtools.library" ; library to check for,
; libv.b=38 ; version number needed.
; If CheckLib {lib$,libv}=0 Then Request "ERROR!","You need "+lib$+" v"+Str$(libv)+"!","Abort":End
; End
;-----------------------------------------------------------------
; Function : OSAssign { assign name, path, type }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; This function creates an assign and returns True if
; successful, false if not.
; The parameters are the assign name (eg. "MyAss:"), the
; path which this assign refers to (eg. "Work:Gfx/Pics"),
; and the type of assign - True (-1) for Path, or False (0)
; for a Late assign.
; Path assigns are activated immediately, Late assigns
; only activate when you try to use them (saves clogging
; up file/path requesters for a start :)
; I've called it OSAssign to avoid confusion with the BSS command
; Assign.
; Also, the function checks for the existence of the path
; you specify, since you CAN assign a name to a non-existent
; drawer! It returns False (0) if the path doesn't exist.
; Sore Point : Don't know how to remove it, except for :
; Execute_ "run >NIL: assign <assign> REMOVE",0,0
Function.b OSAssign {name$,path$,PathOrLate.b}
If Exists(path$)
Select PathOrLate
Case 0 ; LATE assign...starts when accessed.
If AssignLate_(&name$,&path$)
Function Return -1
Else Function Return 0
EndIf
Case -1 ; PATH assign...starts immediately.
If AssignPath_(&name$,&path$)
Function Return -1
Else Function Return 0
EndIf
Default
Function Return 0
End Select
Else Function Return 0
EndIf
End Function
; demo :
;; NOTE : To remove the assign after testing, go to the CLI and
;; type "assign MyAss: REMOVE" (without the quotes!).
; If OSAssign {"MyAss","SYS:C/",-1} ; -1=path assign...
; Request "","Success! MyAss: is assigned to the SYS:C/ drawer!","OK"
; Else Request "","Couldn't assign MyAss: !","OK"
; EndIf
; End
;-----------------------------------------------------------------
; Function : Del { file }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Deletes a file, returning True (-1) for success, False (0)
; for failure to delete.
Function.b Del {f$}
If DeleteFile_ (&f$)
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
;; NOTE : Change the filename before running this demo!
; If Del {"RAM:MadeUpFile.iff"}
; Request "","Deleted!","OK"
; Else Request "","Couldn't delete file!","OK"
; EndIf
; End
;-----------------------------------------------------------------
; Function : OpenShell { x, y, width, height, title, flag(s) }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; This function opens a full CLI window for your user to
; do their stuff (deleting/copying files, anything a normal shell
; can do).
; Program flow is halted until the user closes the shell window,
; either by clicking on the close gadget (if available) or by
; typing "endcli".
; See the error codes and demo to check whether the shell
; function was a success.
; You don't really need to check as much as in the demo;
; just check if OpenShell{}=-1 (successful).
; Note that the width and height aren't too important - the
; window will be made to fit the screen if you give parameters
; which are too large.
; I didn't check the freeing of the console memory (Close_()),
; as there's not much you can do if it doesn't free it!
Function.b OpenShell {x.w,y.w,w.w,h.w,title$,flag$}
win$="CON:"+Str$(x)+"/"+Str$(y)+"/"+Str$(w)+"/"+Str$(h)+"/"+title$+"/"+UCase$(flag$)
; Error codes returned :
; ----------------------
; -1 = Success.
; 0 = Failed to setup console.
; 1 = Failed to create shell from console.
; 2 = Failed to create shell, failed to close console.
; 3 = Succeeded in creating shell, failed to close console.
; What it checks for :
; --------------------
; Did it create the console window?
; Did it turn the console window into a shell?
; Did it close the console?
; Combinations of these...
; Possible Flags :
; ----------------
; (Some of these won't do anything - they are for use on
; non-Shell console windows, eg. information consoles.)
; Flags are separated by a slash / and can be combined...
; ALT - adds a zoom gadget and sets the "zoomed" size :
; Format : ALTx/y/width/height (NOTE - no space
; between ALT and the first number!)
; eg. ALT20/20/300/100
; Others (these descriptions are pretty much the same as
; Blitz window flags) :
; CLOSE/BACKDROP/INACTIVE/NOBORDER/NOCLOSE/NODEPTH/NODRAG
; NOSIZE/SCREEN/SIMPLE (Default)/SMART/WAIT/AUTO
; NOTES : NOBORDER leaves the right-hand border and part
; of the top for some reason!
; SCREEN - supply the name of the screen to open the window
; on, after the SCREEN keyword...eg. CLOSE/SCREEN MadeupScreen/SMART
; SIMPLE - default : text resizes to fit in shrunken/
; expanded window.
; SMART - text doesn't resize.
; WAIT - will only close via close gadget or Ctrl-\
; No use in a Shell window.
*fh.l=Open_(&win$,#MODE_READWRITE)
If *fh
If Execute_ ("",*fh,0)=0 ; failure to create shell :
If Close_ (*fh)=0
Function Return 2 ; failed to create shell AND close console
Else Function Return 1 ; failed to create shell from console
EndIf
Else
If Close_ (*fh)=0
Function Return 3 ; succeeded in creating shell, failed to close console
Else Function Return -1 ; TOTAL SUCCESS :)
EndIf
EndIf
Else Function Return 0 ; failed to setup console
EndIf
End Function
; demo :
; result.b=OpenShell{0,50,640,100,"Hello, I'm a CLI!","CLOSE/ALT30/30/100/100"}
; Select result
; Case -1
; error$="Shell function was a success!"
; Case 0
; error$="Failed to setup console window!"
; Case 1
; error$="Failed to create shell from console!"
; Case 2
; error$="Opened console|Failed to create shell|Can't close console!"
; Case 3
; error$="Succeeded in creating shell|Couldn't close shell window!"
; End Select
; Request "",error$,"OK"
; End
;-----------------------------------------------------------------
; Function : Name { old file name, new name for file }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; This function tries to rename a file to the new name,
; returning True (-1) for success, False (0) for failure.
Function.b Name {old$,new$}
If Rename_ (&old$,&new$)
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
;; IMPORTANT!!! Change the path/file to ones on your system!
;; Choose unimportant ones to save too much hassle!
; If Name {"Stuff:temp/pic.iff","Stuff:temp/pix.iff"}=0
; Request "","Couldn't rename file!","OK"
; EndIf
; End
;-----------------------------------------------------------------
; Function : FileTime { filename }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns a string containing the time the file was created.
; Useful with FileDate.
Function.s FileTime {f$}
lock.l=Lock_(&f$,#ACCESS_READ)
If lock
DEFTYPE .FileInfoBlock fib
If Examine_(lock, fib) <> 0
*date.DateStamp=&fib\fib_Date
time.l=*date\ds_Minute ; minutes past midnight
hrs.w=time/60
mns.w=time-(hrs*60)
time$+Right$("0"+Str$(hrs),2)+":" ; hours
time$+Right$("0"+Str$(mns),2)+":" ; minutes
time$+Right$("0"+Str$(*date\ds_Tick/50),2) ; seconds
Else time$=""
EndIf
UnLock_ lock
Else time$=""
EndIf
Function Return time$
End Function
; demo :
; FindScreen 0
; f$="SYS:Utilities/Multiview"
; Request "","File modification time for :||"+f$+" :||"+FileTime{f$},"OK"
; End
;-----------------------------------------------------------------
; Function : FileDate { filename }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns "Last modified" date of a file as a string.
; See manual for Date$ and DateFormat entries (page 119 for
; Blitz 2) for formatting options.
Function.s FileDate {f$}
lock.l=Lock_(&f$,#ACCESS_READ)
If lock
DEFTYPE .FileInfoBlock fib
If Examine_(lock, fib) <> 0
*date.DateStamp=&fib\fib_Date
dt$=Date$(*date\ds_Days)
Else dt$=""
EndIf
UnLock_ lock
Else dt$=""
EndIf
Function Return dt$
End Function
; demo :
; f$="SYS:Utilities/Multiview"
; d$=FileDate{f$}
; Request "","Last modification date of :||"+f$+" :||"+d$+".","OK"
; End
;-----------------------------------------------------------------
; Function : SetComment { filename, comment }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Tries to write a file comment to the specified file.
; (The comment appears in the Comment section when you look
; at a file's icon using the Icon/Information menu item
; from Workbench.)
; Returns True (-1) if it's successful,False (0) if it fails.
Function.l SetComment{fname$,comment$}
a.l=SetComment_ (&fname$,&comment$)
Function Return a
End Function
; demo :
; filename$="ram:t" ; adds a comment to the Ram:T drawer
; If SetComment{filename$,"Hello,I'm a comment!"}=-1
; Request "","Done it! Now click on the file's icon|and go to the WB Icons/Information menu...","OK"
; Else Request "","Failed to write comment!","Doh!"
; EndIf
; End
;-----------------------------------------------------------------
; Function : ReadComment { filename }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Reads the file comment of the file/drawer you specify.
; Note that you can check for Lock_ and Examine_ failures
; by uncommenting the appropriate lines in the function itself,
; otherwise it just returns "".
Function.s ReadComment {f$}
lock.l=Lock_(&f$,#ACCESS_READ)
If lock
DEFTYPE .FileInfoBlock fib
If Examine_(lock, fib) <> 0
comment$=Peek$(&fib\fib_Comment)
; Else comment$="Failed to examine file"
; ^ Uncomment if you want to check for failure instead of returning ""
EndIf
UnLock_ lock
; Else comment$="Lock failure"
; ^ Uncomment if you want to check for failure instead of returning ""
EndIf
Function Return comment$
End Function
; demo :
;; WARNING!!! Demo uses the SetComment {} function above!
;; After running, click on the file and choose Information
;; from the Workbench menus.
; fl$="RAM:T/" ; file to set/read comment on...
; If SetComment {fl$,"Hello, I'm a comment!"}
; comment$=ReadComment {fl$}
; Request "","Comment for file : ||"+fl$+"||"+Chr$(34)+comment$+Chr$(34),"OK"
; Else Request "","Failed to set comment!","Doh!"
; EndIf
; End
;-----------------------------------------------------------------
; Function : Exist { filename }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; NOTE : This function replaces the IsThere {} function,
; since IsThere {} only told you if the file was there.
; Full replacement for Exists(), but uses OS functions to return
; file size.
; Return values :
; (size) - if none of the below, it's the file's size!
; 0 - can't get a lock (read : file isn't there)
; -1 - file is a directory or disk (same as Exists returns)
; -2 - got lock but couldn't get size (Examine_ failed - rare!)
; This will reduce the size of an executable as well as the fact
; that Exists keeps a file locked until the program ends,
; meaning you can't delete it or perform some other operations
; on it :
; eg. This won't delete the file :
; If Exists("SYS:multiview")
; DeleteFile_ "sys:multiview" ; uh-uh - file's
; EndIf ; locked by Exists!
; But this will :
; If Exist {"SYS:multiview"}
; DeleteFile_ "sys:multiview"
; EndIf
Function.l Exist {f$}
lock.l=Lock_(&f$,#ACCESS_READ)
If lock
DEFTYPE .FileInfoBlock fib
If Examine_(lock, fib) <> 0
If fib\fib_DirEntryType < 0
size=Peek.l(&fib\fib_Size) ; file
Else size=-1 ; drawer
EndIf
Else size=-2 ; failed to examine file! rare occurence!
EndIf
UnLock_ lock
Else size=0 ; failed to lock file (doesn't exist basically)...
EndIf
Function Return size
End Function
; demo :
; f$="SYS:Utilities/Multiview"
; bytes.l=Exist {f$}
; Request "","Size of :||"+f$+"||is "+Str$(bytes)+" bytes.","OK"
; End
;-----------------------------------------------------------------
; Function : CompareDates { file 1, file 2 }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; UPDATED to use OS function CompareDates ()
; Compares the dates of two files, and tells you if the
; first is older than or newer than (or the same age as) the
; second.
; Because CompareDates_ (the OS function) can return
; any value (0, greater than 0, or less than 0), I had
; to return a specific value on "failure to examine/lock"
; a file.
; I chose -999 since it's reasonably easy to remember, and
; I suppose the chances are slim that the function will
; return that exact value (though knowing my luck... ;)
; It means that you should check for -999 to see if it failed,
; and skip the display of relative ages if you get it...
; Also, I discovered that you can't use Select...End Select,
; because it doesn't like being given "Case <0" / "Case >0" ;)
Function.l CompareDates {f1$,f2$}
Dim *dstamp.DateStamp (2)
Dim fib.FileInfoBlock (2)
For a=1 To 2
If a=1 Then f$=f1$ Else f$=f2$ ; the key to my optimisation ;)
lock.l=Lock_(&f$,#ACCESS_READ)
If lock
If Examine_(lock, fib(a)) <> 0
*dstamp(a)=&fib(a)\fib_Date
Else UnLock_ lock:Function Return -999
EndIf
UnLock_ lock
Else Function Return -999
EndIf
Next a
result.l=CompareDates_(*dstamp(1),*dstamp(2))
Function Return result
End Function
; demo :
; files to compare :
; a$="sys:utilities/multiview" ; try swapping a$ and b$ over
; b$="c:copy"
; res.l=CompareDates{a$,b$}
; If res=-999
; Request "","Failed to compare dates!","OK"
; End
; EndIf
; If res=0
; Request "",a$+" and "+b$+" share the same date","OK"
; EndIf
; If res<0
; Request "",a$+" is newer than "+b$,"OK"
; EndIf
; If res>0
; Request "",a$+" is older than "+b$,"OK"
; EndIf
; End
;-----------------------------------------------------------------
; Function : RunFromWB { program }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; (modified from unknown source)
; Tries to run the specified program as if run from the
; Workbench via an icon (so it can use its tooltypes, etc).
; Returns 0 for failure, -1 (True) for success.
; If it fails, just try using Execute_ program$,0,0
; ie. something like :
; If RunFromWB {"sys:utilities/multiview"}=0
; Execute_ "run>NIL: sys:utilities/multiview",0,0
; EndIf
Function.b RunFromWB {prog$}
If Exists(prog$+".info")=0
Function Return 0
EndIf
lib$="wbstart.library"
libv.l=2
*lib.l=OpenLibrary_(&lib$,libv.l)
If *lib
CloseLibrary_ *lib
Else Request "","You need wbstart.library v2!","Abort":End
EndIf
#WBSTART_VERSION = 2
#WBStart_Name = (#TAG_USER + 1)
#WBStart_DirectoryName = (#TAG_USER + 2)
#WBStart_DirectoryLock = (#TAG_USER + 3)
#WBStart_Stack = (#TAG_USER + 4)
#WBStart_Priority = (#TAG_USER + 5)
#WBStart_ArgumentCount = (#TAG_USER + 6)
#WBStart_ArgumentList = (#TAG_USER + 7)
olddir.l = CurrentDir_(0)
Dim wbtags.TagItem(20)
wbtags(0)\ti_Tag = #WBStart_Name, &prog$
wbtags(1)\ti_Tag = #WBStart_DirectoryLock, olddir
success.l = WBStartTagList_(&wbtags(0))
If success=0 Then success=-1 Else success=0 ; true if ran properly!
Function Return success
End Function
; demo :
; program$="sys:utilities/multiview"
; If RunFromWB{program$}
; Else Execute_ "run >NIL: "+program$,0,0
; EndIf
; End
;-----------------------------------------------------------------
; Function : ShowWhy {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns a string to explain why a file input/output
; operation should have failed - the string comes
; directly from the OS...
; You can do stuff like :
; If Exists("SomeFile.txt")
; Request "","Got it !","OK"
; Else Request "",ShowWhy {},"OK"
; EndIf
; Though to be really safe, you should add another character
; in a requester (eg. a full-stop, or period), in case
; there's no string for some weird reason - shouldn't happen,
; but...
; Note, you can change the header$ to whatever suits you,
; but remember the OS adds a colon :
Function$ ShowWhy {}
header$="DOS Error " ; colon : automatically added on...
err$=String$(" ",256) ; kludge up a string buffer ;)
error.l=IoErr_() ; find out WTF the problem is...
If Fault_ (error,&header$,&err$,256) ; get DOS error string...
Function Return err$ ; send it back...
EndIf
End Function
; demo :
; f$="ram:NoSuchDrawer/"
; lock.l=Lock_(&f$,0)
; If lock=0
; Request "","Couldn't lock file!||"+ShowWhy {},"OK"
; EndIf
; End
;-----------------------------------------------------------------
; Function : SetProtect { file, flags }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; With help from David McMinn :)
; Sets file protection flags from Blitz...
; Now you can delete those undeleteable files :)
; IMPORTANT - YOU MUST follow the demo, reading the text in
; there to understand what's going on - this is pretty
; awkward, but it's the easiest way I could do it, thanks
; to the weird way the protection flags get set...
Function.b SetProtect{f$, bits.l}
If SetProtection_(&f$,bits)
Function Return -1 ; success
Else Function Return 0 ; failure
EndIf
End Function
; demo :
;; Don't uncomment until you're told to ;)
;; SPA = Script, Pure, Archive flags.
;; RWED = Readable, Writeable, Executable, Deleteable flags.
;; This is pretty awkward. basically, if you specify any of the
;; SPA bits, they are set and the others (of the SPA) are unset.
;; With the RWED bits, any that you specify are UNSET, and
;; the other RWED bits are SET (ie the opposite of what happens
;; with SPA bits!)
;; So to try and make things easier to follow, do it like this;
;; first specify which of the SPA bits should be set (separated
;; by an | (OR) sign), and then which of the RWED bits should
;; be unset, then OR them together...
;; Jeez...hopefully, the demo itself will make it easier
;; to understand ;)
; From memory, these are the available flags you can set :
;; #FIBF_SCRIPT
;; #FIBF_PURE
;; #FIBF_ARCHIVE
;; #FIBF_READ
;; #FIBF_WRITE
;; #FIBF_EXECUTE
;; #FIBF_DELETE
;;------------------------------
;; OK, uncomment from here :
; SPAbits.l=#FIBF_ARCHIVE ; "A" bit set, "SP" *UNSET*
; RWEDbits.l=#FIBF_WRITE|#FIBF_DELETE ; "WD" unset, "RE" *SET*
; bits=SPAbits|RWEDbits ; combine (OR) them...
; f$="ram:amigaboot.txt" ; change to a non-important file
; on YOUR system!
; If SetProtect{f$,bits}
; Request "","Success!","OK"
; Else Request "","Failure!","OK"
; EndIf
; End
;; now check the file with the icon information requester
;; or shell listing...
;-----------------------------------------------------------------
; Function : AskForDisk { disk name }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; *Slightly* experimental, but seems OK!
; Checks for the requested disk, and returns :
; 1 - if it's missing, and the user cancels the "Insert Disk"
; requester,
; 0 - if the disk is write-protected,
; -1 - if the disk is write-enabled.
; Handy for load - and particularly - save routines :)
; You supply the name of the disk (or drive) and also
; the "protected-report-value" : -1 (True) or 0 (False).
; If you set the report value to -1, it'll give the
; "Retry/Cancel" requester if the disk is write-protected
; whereas setting report to 0 will suppress this, so you can
; just give 'em your "Well, f*** you, then!" message :)
; Basically, if it's -1, they get as many chances as they
; like to unprotect the disk and try again (or hit Cancel)...
Function.b AskForDisk {d$,report.b}
DEFTYPE.InfoData fi
lok.l=Lock_(&d$,#MODE_OLDFILE)
If lok
begin
If Info_(lok,&fi)
If fi\id_DiskState=#ID_WRITE_PROTECTED
If report
If ErrorReport_ (#ERROR_DISK_WRITE_PROTECTED,1,lok,0)=0
Goto begin
Else UnLock_ lok:Function Return 0 ; write-protected
EndIf
Else UnLock_ lok:Function Return 0
EndIf
Else Function Return -1 ; write-enabled
EndIf
EndIf
UnLock_ lok
EndIf
Function Return 1 ; no disk
End Function
; demo :
; Try it with protected and unprotected disks, no disks,
; and stuff like CD-ROMs, with report set to 0 or -1 for
; each, then you'll get the hang of it... ;)
; disk$="DF0:"
; Select AskForDisk {disk$,-1} ; -1 : Retry/Cancel if protected
; Case 1
; Request "","You never inserted "+disk$+" !","OK"
; Case 0
; Request "","Volume "+disk$+" is write-protected!","Fail"
; Case -1
; Request "","Volume "+disk$+" is write-enabled!","OK"
; End Select
; End
;-----------------------------------------------------------------
; Function : DelIcon { icon }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Deletes the specified icon. Automatically removes ".info"
; from icon name if you supply it (you're not supposed to ;)
; This function updates the Workbench screen so that the
; icon disappears if it was visible :)
Function DelIcon {icon$}
If Right$(icon$,5)=".info" Then icon$=Left$(icon$,Len(icon$)-5)
If DeleteDiskObject_ (&icon$)
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
;; note that if you supplied "test" below instead of "test.info",
;; it would still ONLY delete the icon, not the program "test"!
;; oh, and it's safe to call even if the icon's not there, or
;; if it's a default "Show all files" type of icon.
; If DelIcon {"ram:test.info"} ; ...replace with something on
; Request "","Deleted","OK" ; YOUR system!
; Else Request "","Not deleted","OK"
; EndIf
; End
;; Handy hint : the ShowWhy {} function can tell you why it
;; fails to delete the non-existent icon in the demo (or
;; any other reason) :
;; Replace the "Not deleted" requester text with
;; "Not deleted||"+ShowWhy{} to get the DOS error if it fails
;; to delete the icon. You'll have to paste both of these
;; functions into a separate program in order to test it though.
;-----------------------------------------------------------------
.
.Memory
;----------------------------------------------------------------
; These routines deal with memory access or information.
;-----------------------------------------------------------------
; Current routines :
; MemoryFree { type }
; FlushMem {}
; FlushLib { library[.library] }
;-----------------------------------------------------------------
; Function : MemoryFree { type }
; Author : Carl Read - carl@cybercraft.co.nz
; Slight update : renamed it, cos I could never remember
; what Memory {} was for ;)
; Returns size of largest block of available memory -
; use these flags (mostly just use $0, $1, $2, $4, $8000) :
; $0 Any type of memory (0)
; $1 Public (1)
; $2 Chip (2)
; $4 Fast (4)
; $100 Local (256)
; $200 DMAable (512)
; $400 KickTags (1024)
; $20000 Largest chunk (131072)
; $80000 Total memory (524288)
; Note that you can add them together, eg. to check for
; largest single block of Chip RAM, you'd use $2|$20000...
; Oh, and you can replace the numbers with the Blitz
; constants - I've just forgotten them all and can't
; be bothered looking ;)
Function.l MemoryFree {flag.l}
Function Return AvailMem_(flag)
End Function
; demo :
; NPrint MemoryFree {$2} ; $100 from the table above is Chip mem...
; MouseWait:End
;-----------------------------------------------------------------
; Statement : FlushMem {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Same as calling "Avail Flush" from the CLI.
; This makes sure your program has as much free memory as
; possible before starting, loading files, etc.
; Note that some programs don't like having memory flushed at
; certain times (this is the same with "Avail Flush" though),
; so use sparingly!
; Note that there's no need for this to check the return value
; - it's ALWAYS zero!
; This is the way described in the docs for PoolMem, and
; if you run a program called MemPatch (from Aminet), you'll
; see that "Avail Flush" does exactly the same thing ("Avail
; Flush" calls this about 10-15 times though, each time, so
; maybe you'll want to do that...)
; Also, this clears out unused libraries, fonts, etc as well,
; because they get freed only when memory's low, and I think
; this call makes them believe that's the case...does work
; though :)
Statement FlushMem {}
AllocMem_ $7ffffff0,#MEMF_PUBLIC
End Statement
; demo :
;; NOTE - if there's not much memory to be freed, you
;; sometimes find that you lose a few bytes while your
;; program's trying to free the memory, but try running
;; and quitting something big, like Voyager, or calling it
;; right after you've done a whole load of programming
;; (after you've saved your work, obviously!!!), and you
;; should see a big difference...
; NPrint ""
; av1.l=AvailMem_ (#MEMF_PUBLIC)
; NPrint "Available memory : ",av1," bytes."
; NPrint ""
; FlushMem {}
; av2.l=AvailMem_ (#MEMF_PUBLIC)
; NPrint "Available memory : ",av2," bytes."
; NPrint ""
; NPrint "Freed ",-(av1-av2)," bytes." ; if printed number's negative, it's used memory!
; NPrint ""
; NPrint "Click mouse..."
; MouseWait:End
;-----------------------------------------------------------------
; Statement : FlushLib { library[.library] }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Flushes CLI-specified library from system
; if it's not in use.
; RemLibrary () doesn't return a value, hence the reason
; this is just a straight statement.
; Adapted from Krzysztof Cmok's E source.
; More for show, really - better to use the FlushMem {}
; statement further up - it does the same as "Avail Flush",
; which frees all libraries, fonts, etc which aren't in use
; automatically. This is just a nice demo of how to do
; this kind of thing :)
Statement FlushLib {library$}
*exec.ExecBase=Peek.l(4)
*mylist.List=*exec\LibList ; replace DeviceList with LibList, etc...
Forbid_
*libnode.Node=FindName_ (*mylist,&library$)
If *libnode
RemLibrary_ *libnode
EndIf
Permit_
End Statement
; demo :
;; Create as an executable and supply the library
;; name (with .library ending, eg "stc.library")
;; you want to flush...note that most libraries will
;; be in use, but try running a MUI program and calling
;; this on some of the MUI libraries to see it work
;; (in XOpa or similar).
; If NumPars
; a$=Par$(1)
; FlushLib {a$}
; EndIf
; End
;-----------------------------------------------------------------
.
.CLIOnly
;----------------------------------------------------------------
; These are routines which unfortunately only work in
; programs which are run from the CLI. I don't have
; versions that work from Workbench-run programs, otherwise
; this section wouldn't be here!
;-----------------------------------------------------------------
; Current routines :
; ParentDir { directory }
; CurrentDir {}
; GetArg {}
; SetProgName { new program name }
; TextMode { style }
; Echo { text }
;-----------------------------------------------------------------
; Function : ParentDir { directory }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns a string with the parent directory of a given
; directory.
; Only works from CLI-run programs :(
Function.s ParentDir{dir$}
*lok.l=Lock_(&dir$,#ACCESS_READ)
If *lok
*newlock.l=ParentDir_(*lok)
If *newlock
*stringbuffer = AllocMem_(255, 0)
n.l=NameFromLock_ (*newlock, *stringbuffer, 255)
If n
lockname$=Peek$(*stringbuffer)
Function Return lockname$
EndIf
UnLock_ (*newlock)
EndIf
UnLock_(*lok)
EndIf
End Function
; demo :
; d$="Sys:Devs/DosDrivers"
; Print ParentDir{d$}
; MouseWait:End
;-----------------------------------------------------------------
; Function : CurrentDir {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns a string with the current directory name
; only works with CLI-run programs :(
Function.s CurrentDir{}
*stringbuffer = AllocMem_(255, 0)
suc.l=GetCurrentDirName_(*stringbuffer,255)
If suc
cdirname$=Peek$(*stringbuffer)
Function Return cdirname$
Else Request "Info","Couldn't get current directory name!","Oh..."
EndIf
End Function
; demo :
; a$=CurrentDir{}
; Print a$
; MouseWait:End
;-----------------------------------------------------------------
; Function : GetArg {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; CLI only :(
; Returns the parameters supplied to a CLI-run program, like
; Par$()...only difference is, that's all you get - the whole
; argument string...could be useful as an exec-size saving
; function if your program only takes one argument (eg a file-
; name, which you could use this for).
; Only works from compiled executables!
Function.s GetArg{}
*ptr = GetArgStr_()
a$=Peek.s(*ptr)
Function Return Left$(a$,Peek.l(&a$-4)-1)
End Function
; demo :
;; NOTE - You'll have to compile this into an executable
;; and run it from the CLI as "<progname> blah-de-blah".
; Print GetArg{}
; End
;-----------------------------------------------------------------
; Function : SetProgName { new program name }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; CLI only :(
; This function gives your CLI program a new DOS name.
; If you look in XOpa, SnoopDOS or similar, you'll see
; that even if you run your program named "MadeUp", it can
; appear in the system with another name completely.
; Useful if your user renames the program file.
Function SetProgName {name$}
If SetProgramName_ (&name$)
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
; If SetProgName {"I'm a little Test Program!"}=0
; Request "","Failed to set new program name!","OK"
; Else Request "","New program name set!|Go look in XOpa or a similar program!","OK"
; EndIf
; End
;-----------------------------------------------------------------
; Function : TextMode { style }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; CLI-only :(
; Returns a string containing appropriate style tags, so
; you can print in Bold, Italic, etc in the shell. Won't
; work in windows, but may work with printers (at least the bold
; and italic (not the colours!)...
; These are only a few of the codes available, but the most
; common...
; Just call TextMode {} with whatever style you want...
#ClearAndModesOff=1 ; clear shell window, all modes off
#ModesOff=2 ; all modes off
#Bold=3 ; bold text
#FirstCol2=4 ; text uses colour 2 (black)
#Italic=5 ; italic text
#TextCol0=6 ; text colour 0
#TextCol1=7 ; text colour 1
#TextCol2=8 ; text colour 2
#TextCol3=9 ; text colour 3
#Underline=10 ; underlined text
#BackCol0=11 ; background colour 0
#BackCol1=12 ; background colour 1
#BackCol2=13 ; background colour 2
#BackCol3=14 ; background colour 3
#Inverse=15 ; inverse mode text
#Invisible=16 ; blue on blue invisible text
Function$ TextMode {mode.b}
Restore codes
If mode<1 OR mode>16 Then Function Return ""
For a.b=1 To mode
Read mode$
Next a
mode$=Chr$(27)+"["+mode$
Function Return mode$
codes:
Data$ "c","0m","1m","2m","3m","30m","31m","32m","33m","4m","40m","41m","42m","43m","7m",8m
End Function
; demo :
;; for long strings, you'll have to "assemble" them on
;; separate lines, like this!
; a$=TextMode{#TextCol2}+TextMode{#Bold}
; a$+"Hello, I'm bold and white!"+TextMode{#ModesOff}
; a$+TextMode{#Italic}+"...and I'm not!"
; Print a$
; MouseWait:End
;-----------------------------------------------------------------
; Statement : Echo { text }
; Author : FreeJack - Free_Jack@gmx.net
; Size-saving replacement for print - ONLY FOR USE
; IN CLI PROGRAMS! You can't use this in a window!
Statement Echo {t$}
t$+Chr$(10)+Chr$(0)
PutStr_ &t$
End Statement
; demo :
; Echo {"Hello you."}
; MouseWait
; End
;-----------------------------------------------------------------
.
.Versions
;----------------------------------------------------------------
; These routines egenrally return various versions,
; like library versions, Kickstart versions, etc.
;-----------------------------------------------------------------
; Current routines :
; KSVersion {}
; KickVersion {}
; WBVersion {}
; LibVersion { library }
;-----------------------------------------------------------------
; Function : KSVersion {}
; Author : Andreas Falkenhahn - Andreas.Falkenhahn@gmx.de
; Returns version/revision number of user's Kickstart.
; Alternative : see KickVersion {}
; Update - minor bugfix - it used to try and free the
; memory vector after returning, so it wasn't freeing it.
; Also, added check for successful allocation.
Function KSVersion {}
*buf.b=AllocVec_(8,$10001)
If *buf
ver$="Kickstart"
GetVar_ &ver$,*buf,7,0
*tbuf.b=*buf
FreeVec_ *buf
Function Return Val(Peek$(*tbuf))
EndIf
End Function
; demo :
; NPrint "Kickstart : ",KSVersion {}
; MouseWait:End
;-----------------------------------------------------------------
; Function : KickVersion {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns exec.library version, like ExecVersion.
; Alternative : see KSVersion {}.
Function.w KickVersion {}
e$="exec.library"
*lib.Library=OpenLibrary_(&e$,33)
If *lib
v.w=*lib\lib_Version
CloseLibrary_ *lib
EndIf
Function Return v
End Function
; demo :
; NPrint "Kickstart version : ",KickVersion{}
; MouseWait
; End
;-----------------------------------------------------------------
; Function : WBVersion {}
; Author : Andreas Falkenhahn - Andreas.Falkenhahn@gmx.de
; Returns version/revision number of user's Workbench.
Function WBVersion {}
*buf.b=AllocVec_(8,$10001)
ver$="Workbench"
GetVar_ &ver$,*buf,7,0
Function Return Val(Peek$(*buf)) ; -> version is stored in *buf
FreeVec_ *buf
End Function
; demo :
; NPrint "Workbench : ",WBVersion {}
; MouseWait:End
;-----------------------------------------------------------------
; Function : LibVersion { library }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns the version number of the requested library (must
; have full name ("example.library")).
; Didn't bother returning revision, since you can't use
; it for anything anyway (OpenLibrary_() only takes the
; version number)...
; NOTE - returns -1 if the library isn't on the user's system.
Function.w LibVersion {lib$}
*lib.Library=OpenLibrary_(&lib$,0)
If *lib
version.w=*lib\lib_Version
Else version=-1
EndIf
Function Return version
End Function
; demo :
; NPrint LibVersion {"reqtools.library"}
; MouseWait:End
;-----------------------------------------------------------------
.
.Signals
;----------------------------------------------------------------
; These routines deal with sending and receiving various
; intuition/ARexx signals.
;-----------------------------------------------------------------
; Current routines :
; SendARexx { arexx command }
; TimerWait { seconds, microseconds }
; ReceiveCtrlC {}
; SignalTask { taskname, signal }
; WaitForSignal { signal }
;-----------------------------------------------------------------
; Function : SendARexx { arexx command }
; Author : Dave Newton
; Sends a given ARexx command to a given port.
; I'm not gonna pretend to understand ARexx fully, but
; as far as I'm aware, this returns either the "reply
; message" from the port you sent the command to,
; or if an error occurred, an error string.
; Supposedly returns even if you supply a non-existent
; port, so should work just nicely :)
; The demo is from the original source.
Function.s SendARexx{comm$}
*rport.MsgPort=CreateMsgPort(""):okay$="ERROR:-1"
If *rport<>0
*rmsg.RexxMsg=CreateRexxMsg(*rport,"","")
If *rmsg<>0
Forbid_ ;must forbid as rexx port could go without replying!!!!
If FindPort_("REXX")<>0
SendRexxCommand *rmsg,comm$,#RXCOMM|#RXFF_RESULT|#RXFF_NOIO|#RXFF_STRING
Permit_:WaitPort_ *rport:*rmsg=GetMsg_(*rport) ;give os multitasking back as soon as possible
If (*rmsg\rm_Result1=0)&(*rmsg\rm_Result2<>0)
okay$=Peek$(*rmsg\rm_Result2)
Else
okay$="ERROR:"+Str$(*rmsg\rm_Result1)+"-"+Str$(*rmsg\rm_Result2)
EndIf
ClearRexxMsg *rmsg:DeleteRexxMsg *rmsg
EndIf
Else
Permit_ ;give task switching back if no rexx port
EndIf
DeleteMsgPort *rport
EndIf
Function Return okay$
End Function
; demo :
;; NOTE : this demo checks for Multiview's port,
;; and sends a message to open a new file...so run
;; multiview first!
;; You should get a file requester, which loads
;; a file into the open copy of multiview.
;; If there's more than one copy of multiview running,
;; other copies will have names like Multiview.2, Multiview.3,
;; and so on.
; a$=SendARexx{"Address Multiview.1 OPEN"}
; Print a$
;; I don't understand the error codes - this works, but returns
;; a$ as "Error 0-0" !
; End
;-----------------------------------------------------------------
; Function : TimerWait { seconds, microseconds }
; Author : taken from Andrea Doimo's BlitzFAQ website...
; - various authors contributed, so unknown...
; Sets up the timer.device to wait for set amount of
; time in seconds and microseconds (1/1,000,000 secs).
; So a half-second wait would be TimerWait {0,500000},
; 1.2 seconds would be TimerWait {1,200000}, etc.
; Returned values :
; 0 = No error
; 1 = Failed to open timer.device
; 2 = Failed to open message port
; 3 = Failed to create a timer request
; There's not much you can do if it fails, so just
; use ** If TimerWait {s,m}=0 Then Print "Fail" **
; or ** dummy.b=TimerWait {s,m} ** or whatever.
; I don't think much can fail though.
Function.b TimerWait {sec.l, mic.l}
*TimerMP.MsgPort = CreateMsgPort_()
If *TimerMP
*TimerIO.timerequest = CreateIORequest_ (*TimerMP,SizeOf .timerequest)
If *TimerIO
err = OpenDevice_ ("timer.device",#UNIT_MICROHZ,*TimerIO,0)
If err Then Function Return 1
*TimerIO\tr_node\io_Command = #TR_ADDREQUEST
*TimerIO\tr_time\tv_secs = sec
*TimerIO\tr_time\tv_micro = mic
SendIO_ *TimerIO
WaitPort_ *TimerMP
Repeat
*TimerMsg.Message = GetMsg_(*TimerMP)
Until *TimerMsg = 0
CloseDevice_ (*TimerIO)
DeleteIORequest_ (*TimerIO)
DeleteMsgPort_ (*TimerMP)
Function Return 0
Else
Function Return 3
EndIf
Else Function Return 2
EndIf
End Function
; demo :
; NPrint "Counting to five..."
; NPrint ""
; For a=1 To 5
;; Wait one second each time :
; If TimerWait {1,0}<>0 Then Request "","Failed!","OK"
; NPrint " ",a
; Next a
; dummy.b=TimerWait {1,0} ; pause for a second...
; End
;-----------------------------------------------------------------
; Function : ReceiveCtrlC {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Update : Thanks to David McMinn for pointing out that the
; CtrlC {} statement used to set this up previously was
; totally pointless!
; Captures Ctrl-C messages sent to the program from either
; the CLI it's run from, or other programs, such as XOpa,
; or Executive's Commander.
; Put it into all loops you want to break.
Function ReceiveCtrlC {}
If (SetSignal_(0,#SIGBREAKF_CTRL_C) & #SIGBREAKF_CTRL_C)
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
; FindScreen 0
; Window 0,0,0,640,100,$140f,"Hit close gadget or send a Ctrl-C to quit...",1,2
; Repeat
; If ReceiveCtrlC {} Then Request "","Ctrl-C received!","END":End
; VWait
; Until Event=$200
; End
;-----------------------------------------------------------------
; Function : SignalTask { taskname, signal }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Sends a command (eg. CTRL-C) to a program, returning -1 (True)
; if it sent the signal (NOTE that this doesn't necessarily mean
; the program did as it was told - not all programs support
; Ctrl-C messages, etc). Returns 0 (False) if it couldn't find
; the program.
; You should note that the taskname is CASE-SENSITIVE (not my
; choice ;) and that it can change depending on whether it
; was run from the shell or from Workbench...and stuff...
; Possible signals you can send :
; #SIGBREAKF_CTRL_C (4096) - quit program
; #SIGBREAKF_CTRL_D (8192) - disable program (sleep)
; #SIGBREAKF_CTRL_E (16384) - enable program (wake up)
; #SIGBREAKF_CTRL_F (32768) - um...can't remember...
; NOTE : Signals have different effects depending on the
; receiving program's interpretation, but these are the general
; conventions.
Function.b SignalTask {task$,sig.l}
*task.Task=FindTask_(&task$)
If *task
Signal_ *task,sig
Function Return -1
Else Function Return 0
EndIf
End Function
; demo :
;; NOTE : depending on your setup, your copy may have
;; "MultiView" in different casing, eg "multiview" - adjust
;; accordingly!
; t$="MultiView"
; If SignalTask{t$,#SIGBREAKF_CTRL_C}
; Request "","Signalled "+t$+"!","OK"
; Else Request "","Can't find "+t$+"!","OK"
; EndIf
; End
;-----------------------------------------------------------------
; Statement : WaitForSignal { signal }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Puts your program to sleep, using 0% CPU time, until the user
; sends the message you've asked for (eg Ctrl C).
; NOTE that this can leave your user unable to continue
; your program if they don't have a tool to send the
; command, so best used from CLI (eg. Print "Press Ctrl-C" or
; whatever before calling the statement), but may be useful
; in other situations.
; Run the demo and press Ctrl and C together, or send a
; Ctrl C (BREAK) signal from a program like XOpa, ARTM,
; Commander, etc...
; Possible signals are listed below :
; #SIGBREAKF_CTRL_C
; #SIGBREAKF_CTRL_D
; #SIGBREAKF_CTRL_E
; #SIGBREAKF_CTRL_F
Statement WaitForSignal {sig.l}
SetSignal_ 0,sig ; clear previous occurrences (sp?!)
Wait_ sig
End Statement
; demo
; WaitForSignal {#SIGBREAKF_CTRL_C}
; End
;-----------------------------------------------------------------
.
.Misc
;----------------------------------------------------------------
; These routines didn't really fit anywhere else.
; A lot of them deal with information about the currently
; running program (ie your program!) though.
;-----------------------------------------------------------------
; Current routines :
; ProgsDir {}
; ProgsName {}
; SetPriority { priority }
; Language {}
; StupidRequest { title, body text }
;-----------------------------------------------------------------
; Function : ProgsDir {}
; Author : Nick Clover - nick@bauk.freeserve.co.uk
; Returns a string with the program's directory.
; IMPORTANT! Only works with compiled executables,as
; Compiling & Running doesn't use a directory (obviously ;)
; **** REPLACEMENT by Nick Clover ****
; Now returns program directory when run from WB as well!
; Cool :)
; UPDATE - renamed to ProgsDir, to keep in line with ProgsName,
; because ProgDir is a Blitz Support Suite command.
Function.s ProgsDir{}
MaxLen path$=200
NameFromLock_ GetProgramDir_(),&path$,200
path$=Peek$(&path$)
If Right$(path$,1)<>":" AND Right$(path$,1)<>"/"
path$+"/"
EndIf
If path$="SYS:" Then path$="I only work when compiled!"
Function Return path$
End Function
; demo :
;; note that this returns a name only from executables!
;; you'll just get a blank string if you run it from Blitz!
; Request "","Path : "+ProgsDir{},"OK"
; End
;-----------------------------------------------------------------
; Function : ProgsName {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; UPDATED by Nick Clover - nick@bauk.freeserve.co.uk
; Now works when run from WB as well! Means your user can
; rename the program if they wish and you can still find
; your icon's tooltypes or whatever :)
; UPDATED - Curt Esser reported that the name clashes
; with a command in the Blitz Support Suite.
; Now ProgsName instead of ProgName.
; Returns a string with the program's DOS name, handy when used
; with ProgsDir{} (eg. progpath$=ProgsDir{}+ProgsName{} )...
Function.s ProgsName{}
If FromCLI=-1
*stringbuffer = AllocMem_(255, 0)
suc.l=GetProgramName_(*stringbuffer,255)
If suc
pname$=Peek$(*stringbuffer)
EndIf
FreeMem_ *stringbuffer,255
Else pname$=Peek$(Peek.l(FindTask_(0)+$B0)+4)
EndIf
If pname$="" Then pname$="I only work when compiled!"
Function Return pname$
End Function
; demo :
;; note that this returns a name only from executables!
; a$=ProgsName{}
; Request "","Program name : "+a$,"OK"
; End
;-----------------------------------------------------------------
; Function : SetPriority { priority }
; Author : Peter Thor - email?
; priority check added by JLB
; Sets the priority of your program to whatever you want.
; Negative numbers mean higher priority (roughly : more CPU
; time). Priority can be from -127 to +127. Positive numbers
; mean higher priority. It's recommended that most programs
; shouldn't use higher than 5-10 as far as I remember, but
; as long as you know what you're doing, you can crank it
; up to whatever you want (up to 127!), or make it low if
; it doesn't need much CPU time).
; Returns value of priority before function was called, so
; you just call SetPriority {returned value} to put it
; back how it was.
; Couldn't really decide how to return a failure, so just
; returns 0, which is still a valid value! Adjust it to suit
; your needs!
Function.w SetPriority{newpriority.w}
If newpriority<-127 OR newpriority>127 Then Function Return 0
Forbid_ ;lock system to check for task
*task.l=FindTask_(*crap.l) ;*crap.l is only a NULL-Pointer
;this way the task of the program itself
;is returned
; set the new priority:
oldpriority.w=SetTaskPri_(*task,newpriority.w)
Permit_ ;and return the system
Function Return oldpriority.w
End Function
; demo :
;; NOTE : Use XOpa or similar program to see priority. If you're
;; running from Blitz, it'll be the "Blitz ][ Program Proc" you're
;; looking for. With most of these type of programs, you'll have
;; to update the task list to see the change.
;; I use Executive, which I think modifies the priority you
;; set, so I sometimes get some weird number listed, but it
;; basically works!
; Repeat
; Print "Priority (-127 to 127), 1000 to end : "
; a.w=Edit(4)
; If a=1000 Then End
; oldpri.w=SetPriority {a}
; NPrint "The old priority was : ",oldpri
; NPrint ""
; Forever
;-----------------------------------------------------------------
; Function - Language {}
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; Returns a string containing the user's default
; language as set in their Locale preferences.
; Should still work (well, fail safely!) on <OS2.0
; because it checks for the locale.library before
; calling OpenLocale_ (). Mail me if you've tried it!
; Useful for custom locale setups, eg. ascii files
; full of strings for each language. If the file for
; the language returned by this function exists, use
; it, and if not (or if you get an empty ("") string
; returned), just give your user a default language.
; Saves the hassle of proper locale setups, and
; should work just as well ;)
Function$ Language {}
l$="locale.library"
*loclib=OpenLibrary_ (&l$,0)
If *loclib
*locale.Locale=OpenLocale_(0)
If *locale
country$=Peek$(*locale\loc_LanguageName)
CloseLocale_ *locale
EndIf
CloseLibrary_ *loclib
EndIf
If country$
country$=Left$(country$,Len(country$)-9)
EndIf
Function Return country$
End Function
; demo :
; NPrint ""
; a$=Language {}
; If a$
; NPrint "User's Workbench uses ",a$," locale."
; Else NPrint "Can't find locale settings, using english!"
; EndIf
; MouseWait:End
;-----------------------------------------------------------------
; Statement : StupidRequest { title, body text }
; Author : James L Boyd - jamesboyd@all-hail.freeserve.co.uk
; This statement is probably useless for most people, but
; we used it in BeatBox2 to generate 'amusing' error requesters
; when people make mistakes - you supply the title and error text,
; and this just adds an incredibly, side-splittingly funny
; gadget (maybe not... ;)
; You can easily replace all the strings, but make sure you
; adjust the number of strings used in the first Data
; statement.
; As I said, nothing special, but it's just a little idea
; to make things (slightly) more interesting by making things
; a little random...
Statement StupidRequest {title$,body$}
Restore stupidstrings
Read t
r=Int(Rnd*t)+1
For a=1 To r
Read stupid$
Next a
If body$="" OR stupid$="" Then Statement Return
Request title$,body$,stupid$
Statement Return
stupidstrings:
Data 26 ; number of strings - ADJUST if you add/remove strings!
Data$ "Doh!","Oh,OK...","It's a wonder I'm still breathing!","Gotcha!","I see...","Hmm...makes sense!","Oh,great!"
Data$ "Oh,yeah...","Ahh!","Oh,I get it now!","It's all so obvious now!","Oh,right...","Sorry,I'm stupid!","You lousy *#@$!"
Data$ "I'm learning!","Ooh...","AAARRRGGGHHHHH!!!","Grrr...","Where's the 'Any' key?","I'm lost...","'Easy' indeed..."
Data$ "My other computer's a PC!","NOOOOoooooo.....","Just testing!","I should be using Windows...","I'm a Mac user..."
End Statement
; demo :
; StupidRequest{"My Program","You've made a big mistake!"}
; End
;-----------------------------------------------------------------
Request "statements&functions.bb2","You can't just run this!","Oh..."
End ; just in case ;)